- QWERTY billentyűzet és másodlagos kijelző is lesz a Titan 2-ben
- Apple Watch
- Netfone
- iPhone 16e - ellenvetésem lenne
- Megindult világhódító útjára az új Samsung fülhallgató
- Hat év támogatást csomagolt fém házba a OnePlus Nord 4
- Magisk
- Garmin Forerunner 970 - fogd a pénzt, és fuss!
- Xiaomi 14T Pro - teljes a család?
- iPhone topik
-
Mobilarena
A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.
Új hozzászólás Aktív témák
-
Delila_1
veterán
válasz
enelna
#22123
üzenetére
Ez meg az óraszámot is beírja a H oszlopba:
Sub Szabi_Ora()
Dim sor As Integer, sz As String, hova As Integer
Dim ora As Integer
hova = Columns(5).Find("Szabadság").Row
For sor = 10 To 40
If Cells(sor, "E") = "Szabadság" Then
sz = sz & Cells(sor, "A") & "; "
ora = ora + 8
End If
Next
Cells(hova, "F") = Left(sz, Len(sz) - 2)
Cells(hova, "H") = ora
End Sub -
Delila_1
veterán
válasz
enelna
#22123
üzenetére
Ez a makró beírja:
Sub Szabi()
Dim sor As Integer, sz As String, hova As Integer
hova = Columns(5).Find("Szabadság").Row
For sor = 10 To 40
If Cells(sor, "E") = "Szabadság" Then
sz = sz & Cells(sor, "A") & "; "
End If
Next
Cells(hova, "F") = Left(sz, Len(sz) - 2)
End Sub -
Delila_1
veterán
válasz
enelna
#22118
üzenetére
Másképp oldanám meg. Az A és B oszlopra feltételes formázást adnék, ahol a képlet
=$B1="SZ"
és a háttérszínt pl. pirosra állítanám. Minden sor A és B oszlopában, ahol a B oszlop tartalma SZ, pirosra váltana a háttér.
A szabadságok darabszámát a
=DARABTELI(B:B;"SZ")
képlet adja meg a lapon.
-
#22117
Delila_1
veterán
King Unique
#22116
Delila_1
veterán
válasz
King Unique
#22116
üzenetére
-
#22115
Delila_1
veterán
King Unique
#22114
Delila_1
veterán
válasz
King Unique
#22114
üzenetére
A legördülőnél meg kell adnod, hogy honnan vegye az adatait, ez a ListFillRange tulajdonság. A küldött füzetben Munka1!AA1:AA8. A cellacsatolás az a hely, ahova a kiválasztott érték kerül, LinkedCell, ebben az esetben Munka1!AB1.
Mindkettő akkor igaz, ha az ActiveX vezérlőket használod a lapon. Alkalmazhatod az Űrlapvezérlőket is, ott a tulajdonságainál magyarul írják a két terület nevét.
-
#22113
Delila_1
veterán
King Unique
#22111
Delila_1
veterán
válasz
King Unique
#22111
üzenetére
Bemásoltam innen a makrókat egy füzetbe, elküldöm.
-
#22112
Delila_1
veterán
King Unique
#22111
Delila_1
veterán
válasz
King Unique
#22111
üzenetére
Állandónak ajánlom, és mindenkinek. Sok új függvényt elérsz vele a füzetben, és a VBA-ban is, amik enélkül nem mennek.
A Combobox cellacsatolását betetted az AB1 cellába?
-
#22110
Delila_1
veterán
King Unique
#22109
Delila_1
veterán
válasz
King Unique
#22109
üzenetére
Kapcsold be az Analysis Toolpak és az Analysis Toolpak - VBA nevű bővítményeket.
-
Delila_1
veterán
válasz
csendes
#22105
üzenetére
Egyszer egy ilyen esetben a következőt csináltam (eredménnyel):
Ctrl+g-vel behívtam az Ugrás menüt, ott az Irányított gomb megnyomása után kiválasztottam az Objektumokat. Kijelölt egy nagy halom objektumot, képeket, gombokat, amiknél csak a sarkaikon lévő jelölők látszottak. Nem léptem ki a jelölésből, hanem a Delete gombbal az összeset egyszerre töröltem. Mentés után drasztikusan csökkent a fájl mérete.
A fájl tulajdonosa nem tudta, mikor és hogy kerültek be ezek.
Egy próbát megér. -
#22102
Delila_1
veterán
King Unique
#22101
Delila_1
veterán
válasz
King Unique
#22101
üzenetére
Szívesen.
-
#22100
Delila_1
veterán
King Unique
#22099
Delila_1
veterán
válasz
King Unique
#22099
üzenetére
If CV.Value Like ("[AEIOU]") Then -> ha a ciklusváltozó (CV) egyenlő a LIKE kulcsszó utáni valamelyik karakterrel, akkor...
Az A ASCII értéke 65. Le tudod kérdezni a KÓD függvénnyel. Az i itt egy 1 és 26 közötti véletlen egész szám. A Chr(i+64) egy 65 és 90 közötti értéknek megfelelő karaktert adja, A-tól Z-ig.
A kis a betű ASCII kódja 97, ott az i-hez 96-ot kell adni.
Kulcsszavakat nem adhatunk változónévként, ezért a maxx.
Minden maxx-szal azonos értékű cella színezése:
Range("A1").Select
hely = Selection.CurrentRegion.Address
maxx = Application.Max(Range(hely))
For Each CV In Range(hely)
If CV = maxx Then Range(CV.Address).Font.ColorIndex = 5
Next -
#22097
Delila_1
veterán
King Unique
#22094
Delila_1
veterán
válasz
King Unique
#22094
üzenetére
Második kérdés: a legördülő csatolását az AB1 cellába tettem.
Private Sub General1_Click()
Dim szam As Integer, CV As Object
Dim also As Integer, felso As Integer
Dim hely As String
Range("A1").Select
Selection.CurrentRegion.Font.ColorIndex = 0
Selection.CurrentRegion.ClearContents
szam = Range("AB1")
also = 1: felso = 100
For Each CV In Range(Cells(1, 1), Cells(szam, szam))
Randomize
CV = Round(Rnd * (felso - also) + also, 0)
Next
End SubPrivate Sub Max_Click()
Dim maxx As Integer, hely As String, CV As Object, cim As String
Range("A1").Select
hely = Selection.CurrentRegion.Address
maxx = Application.Max(Range(hely))
cim = Range(hely).Find(maxx).Address
Range(cim).Font.ColorIndex = 5
MsgBox "A maximális érték helye: " & cim & ", " & _
"értéke: " & maxx
End Sub -
#22096
Delila_1
veterán
King Unique
#22094
Delila_1
veterán
válasz
King Unique
#22094
üzenetére
Az első kérdéshez:
Private Sub General_Click()
Dim tomb(26), sor As Integer, oszlop As Integer, i As Integer
Dim usor As Integer, uoszlop As Integer
Dim felso As Integer, also As Integer
Range("A1:Z26").ClearContents
Range("A1:Z26").Font.ColorIndex = 0
Randomize
also = 1: felso = 5
usor = Round(Rnd * (felso - also) + also, 0)
felso = Int(26 / usor)
Randomize
uoszlop = Round(Rnd * (felso - also) + also, 0)
For sor = 1 To usor
For oszlop = 1 To uoszlop
Ujra:
Randomize
felso = 26
i = Round(Rnd * (felso - also) + also, 0)
If tomb(i) > 0 Then GoTo Ujra
tomb(i) = i
Cells(sor, oszlop) = Chr(i + 64)
Next
Next
End SubPrivate Sub Kiemel_Click()
Dim terulet As String, CV As Object
Range("A1").Select
terulet = Selection.CurrentRegion.Address
For Each CV In Range(terulet)
If CV.Value Like ("[AEIOU]") Then CV.Font.ColorIndex = 3
Next
End Sub -
Delila_1
veterán
Ennél az elrendezésnél a 2003-as verzió képlete a G2 cellában:
=HA(HIBÁS(HOL.VAN(A2;J:J;0));"új tétel";HA(INDEX(J:O;HOL.VAN(A2;J:J;0);6)=F2;"maradt";"változott"))
2007-től kicsit egyszerűbb a HAHIBA függvény bevezetése által:
=HAHIBA(HA(INDEX(J:O;HOL.VAN(A2;J:J;0);6)=F2;"maradt";"változott");"új tétel")
-
Delila_1
veterán
válasz
DopeBob
#22062
üzenetére
"a mai naphoz képes egy héten belülre kerül".
Ezt úgy érted, hogy az aktuális dátumhoz képest az 1 héttel előbbi, és 1 héttel későbbi dátumot tartalmazó cellákat akarod formázni? Ha igen, a képlet a lenti (persze ha A1-ben kezdődnek a dátumaid.
=ÉS(A1>=MA()-7;A1<=MA()+7)
-
Delila_1
veterán
válasz
Prancz
#22050
üzenetére
Nevezd el a rövidítéseket tartalmazó tartományt rövidítésre, a magyarázatok 2 oszloposát pedig teljesre. A makrót lefuttatva megkapod az eredményt.
Sub csere()
Dim cv As Object
For Each cv In Range("rövidítés")
Range(cv.Address) = Application.VLookup(cv, Range("teljes"), 2, 0)
Next
End Sub -
Delila_1
veterán
válasz
bepken
#22038
üzenetére
Próbáld ki ezzel:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
Application.EnableEvents = False
On Error GoTo Hiba
If Target.Value <> "" Then
Cells(Target.Row, 2) = Date
Cells(Target.Row, 2).NumberFormat = "yy/mm/dd"
Else
Cells(Target.Row, 2) = ""
End If
Application.EnableEvents = True
End If
Exit Sub
Hiba:
MsgBox "Egyszerre csak egy adatot adj meg, vagy törölj!", vbOKOnly + vbExclamation
Application.EnableEvents = True
End Sub -
-
Delila_1
veterán
válasz
valkesz93
#22032
üzenetére
• Hol adod meg, hogy pl. a B170 tartalmát keresed?
• Ha nem talál, mi legyen?
• Ha a 20. sorban talál azonos értéket, akkor a C20:C170, stb tartományt másolja?
• Hova másoljon? A keresett cella mellé? Most adatok vannak mellette. Felülírja azokat, vagy egy üres oszloptól kezdve valahova? -
Delila_1
veterán
válasz
#02644736
#22031
üzenetére
A lapodhoz kell rendelned a lenti makrót, ennek a módját több helyen megtalálod a fórumon.
Az X1 helyett olyan címet írj, ahol biztosan nincs adatod.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Application.EnableEvents = False
Range("A1") = Range("X1") + Target
Range("X1") = Range("A1")
Application.EnableEvents = True
End If
End Sub -
Delila_1
veterán
válasz
bepken
#22025
üzenetére
Igen, az a baja.
Egy kicsit másképp a makró. Ebben már az is benne van, hogy egyszer fusson le. Mikor beírsz a lapra valamit, beíródik a B oszlopba a dátum, erre újból lefut az EnableEvents ideiglenes letiltása nélkül.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Value <> "" Then
Cells(Target.Row, 2) = Date
Cells(Target.Row, 2).NumberFormat = "yy/mm/dd"
Else
Cells(Target.Row, 2) = ""
End If
Application.EnableEvents = True
End SubMivel a C oszlop változtatását akarod figyeltetni, érdemes az egészet egy feltételbe beírni.
if target.column=3 then
...
endif -
#22022
Delila_1
veterán
LordVader80
#22021
Delila_1
veterán
válasz
LordVader80
#22021
üzenetére
Szívesen.
-
#22020
Delila_1
veterán
LordVader80
#22019
Delila_1
veterán
válasz
LordVader80
#22019
üzenetére
Most már csak a kibővített feltételt írom be.
If CV > "" Then
CV.Copy
Sheets("Munka2").Range("A" & sor).PasteSpecial xlFormats
Sheets("Munka2").Range("A" & sor).PasteSpecial xlValues
sor = sor + 1
End If -
#22018
Delila_1
veterán
lordeklvin
#22017
Delila_1
veterán
válasz
lordeklvin
#22017
üzenetére
Szívesen.
-
#22016
Delila_1
veterán
LordVader80
#22015
Delila_1
veterán
válasz
LordVader80
#22015
üzenetére
Kiegészítve az üres cellák másolásának elhagyásával:
Sub Egymas_ala()
Dim ter As String, CV As Object, sor As Long
Range("A1").Select '*
ter = Selection.CurrentRegion.Address
sor = 1
For Each CV In Range(ter)
If CV > "" Then
Sheets("Munka2").Range("A" & sor) = CV.Value '**
sor = sor + 1
End If
Next
End Sub -
#22014
Delila_1
veterán
lordeklvin
#22010
Delila_1
veterán
válasz
lordeklvin
#22010
üzenetére
Ezt a szép hosszú képletet tedd egy másik oszlopba, a C-ben meg – ahol a / utáni részt akarod megjeleníteni – hivatkozz erre a segédoszlopra.
-
#22012
Delila_1
veterán
LordVader80
#22011
Delila_1
veterán
válasz
LordVader80
#22011
üzenetére
Az eredeti lapon lévő, A1 cellában kezdődő táblázat adatait másolja a makró a Munka2 lapra abban a sorrendben, ahogy írtad.
Két helyen kell módosítanod a makróban, ahol megjelöltem.
'* ha nem az A1-ben kezdődik a táblázatod, '** ha nem Munka2 a másolat lap neve.Sub Egymas_ala()
Dim ter As String, CV As Object, sor As Long
Range("A1").Select '*
ter = Selection.CurrentRegion.Address
sor = 1
For Each CV In Range(ter)
Sheets("Munka2").Range("A" & sor) = CV.Value '**
sor = sor + 1
Next
End Sub -
Delila_1
veterán
válasz
kopogo
#22006
üzenetére
Az első kérdés megválaszolásához szükséges a füzet ismerete.
A másodiknál érvényesítést kell bevinned, ahol egész számot engedsz meg, minimum érték 1, maximum 5000.
A Hibajelzés fülön a Hibaüzenet rovatban adod meg a szöveget.
Az oszlopra feltételes formázást adsz. Itt a képlet =I1>2000, formátumként pedig beállítod a háttérszínt. -
#22007
Delila_1
veterán
lordeklvin
#22005
Delila_1
veterán
válasz
lordeklvin
#22005
üzenetére
A kép alapján nekem nem egészen tiszta, melyik adatoknak a / jel utáni részét akarod megjeleníteni, és hol.
Vegyük, hogy az adat (6:00/0) a C10-ben van. A képlet
=JOBB(C10;HOSSZ(C10)-SZÖVEG.KERES("/";C10)) -
Delila_1
veterán
válasz
tgumis
#22000
üzenetére
Az Összesítés lap A1 cellája az első-, az A2 az utolsó hónap, amit összesíteni akarsz.
Legegyszerűbb, ha minden lapon egy cellában összesíted az aznapi eladásokat. Legyen ez a példában az N1 cella. Ha a bevételeid a D oszlopban vannak, akkor az N1 képlete =SZUM(D:D).A makró az Összesítés lap B4 cellájába írja be a beírt lapok összbevételét.
Sub Osszesen()
Dim lap%, elso%, ucso%, osszes As Long
elso% = Sheets("Összesítés").Range("A1")
ucso% = Sheets("Összesítés").Range("A2")
For lap% = elso% To ucso%
osszes = osszes + Sheets(lap%).Range("N1")
Next
Sheets("Összesítés").Range("B4") = osszes
End Sub -
Delila_1
veterán
válasz
Pityke78
#21981
üzenetére
Képletek | Definiált nevek | Névkezelő
Megjelennek egy listában a felvitt nevek. Ráállsz a módosítandóra, és lent, a hivatkozás mezőben átírod a területet.
Kicsit furfangosan írták meg az Excel fejlesztői ezt a részt. Legjobb, ha a beírt $A$1:$A$15-ben kijelölöd a második A-t, és átírod B-re, másképp hajlamos annak a cellának a címét beírni, amelyiken éppen állsz a füzetben. -
Delila_1
veterán
válasz
demarad
#21977
üzenetére
A kódot így fejtettem meg:
Kijelöltem és másoltam a szóköznek látszó karaktert, majd beillesztettem egy cellába. Erre a cellára hivatkoztam a KÓD függvénnyel, ami kidobta a 160-at.Erre nincs szükség, hiszen közvetlenül a Csere funkcióhoz is beilleszthetjük a cserélendő karaktert, csak gondoltam, hátha érdekel.
-
Delila_1
veterán
válasz
demarad
#21973
üzenetére
A csatolt füzetedben a látszólagos szóköz igazán egy 160-as kódú láthatatlan karakter.
Állj az egyik ilyen cellára, jelöld ki a szóköznek látszó karaktert, Ctrl+c-vel tedd a vágólapra.
Hívd be a Csere funkciót, és Ctrl+v-vel másold be a vágólapról a Keresett szöveg rovatba. A Csere erre rovatot hagyd üresen, nyomd meg Az összes cseréje gombot.Utána már kedved szerint módosíthatod a tartományod formátumát.
-
Delila_1
veterán
Nálam a formon a két objektum ComboBox1, és Image1 névre hallgat.
A ComboBox1 listáját megadod a RowSource tulajdonságánál, pl. Munka1!A1:A10, ez a tartomány tartalmazza a képfájlok nevét, kiterjesztés nélkül. A Style tulajdonság legyen fmStyleDropDownList, hogy csak a felajánlott nevekből lehessen választani, ne lehessen új tételt beírni.
Az Image1 PictureSizeMode tulajdonsága legyen fmPictureSizeModeZoom, hogy bármelyik kép megjelenítése kitöltse az objektumot.
A makró:
Private Sub ComboBox1_Change()
Dim Fname As String
Fname = "F:\Jpg\Festmenyek\" & ComboBox1 & ".jpg"
Image1.Picture = LoadPicture(Fname)
End SubTermészetesen a saját útvonaladat, és a képeid kiterjesztését add meg az Fname változóban.
-
#21970
Delila_1
veterán
ElemiKoczka
#21969
Delila_1
veterán
válasz
ElemiKoczka
#21969
üzenetére
Privátban megadom a címet.
-
#21968
Delila_1
veterán
ElemiKoczka
#21967
Delila_1
veterán
válasz
ElemiKoczka
#21967
üzenetére
Louro ötletét tartom jónak.
Nem számít, hogy az első tétel C oszlopában mi van. A képletben az =1 nem arra vonatkozik. -
#21965
Delila_1
veterán
ElemiKoczka
#21961
Delila_1
veterán
válasz
ElemiKoczka
#21961
üzenetére
Az A oszlopban az egyes termékek nevéből csak az első legyen látható, a többinél a karakter színe egyezzen meg a cella háttérszínével.
Ez példa arra az esetre, ha nem fogadod meg Louro tanácsát.
-
#21963
Delila_1
veterán
FastEthernet
#21960
Delila_1
veterán
válasz
FastEthernet
#21960
üzenetére
Az idézett linken elolvashatod, hogy alakíthatod át az A oszlopodat úgy, hogy megszünteted a cellák összevonását. A példában B oszlopról van szó, de ez biztosan nem okoz gondot.
Egy feltételes formázással elérheted, hogy a 3 sor közül a felső és az alsó karakterei a háttérszínnel megegyezzenek, így nem zavarnak be az összképbe. A szegélyeket is feltételes formázással határozhatod meg. A2-től lefelé a két formátum:
=A2<>A1 formátum: karakter fehér, szegély felül
=A2<>A3 formátum: karakter fehér, szegély alul -
Delila_1
veterán
-
-
#21936
Delila_1
veterán
Apollo17hu
#21935
Delila_1
veterán
válasz
Apollo17hu
#21935
üzenetére
A kép ahhoz a cellához tartozik, amelyikben a bal felső sarka van. A 3 cella szélességű kép utolsó két cellája már kívül esik a táblázaton, ezt jelezte hibaként.
-
#21934
Delila_1
veterán
Apollo17hu
#21933
Delila_1
veterán
válasz
Apollo17hu
#21933
üzenetére
2010-es verzióban a tulajdonságoknál az "Áthelyezés és átméretezés a cellákkal együtt" opciót kiválasztva rendezésnél követik a cellájukat a beszúrt képek.
-
#21932
Delila_1
veterán
Fire/SOUL/CD
#21931
Delila_1
veterán
válasz
Fire/SOUL/CD
#21931
üzenetére
Segédoszlopokkal tudom csak elképzelni.
Az eredeti tartományból speciális (lánynevén irányított) szűréssel létrehoznék egy újat, ami kiszűri az ismétlődéseket, majd a GYAKORISÁG tömbfüggvényben ezt venném második paraméternek (első az eredeti tartomány).
-
Delila_1
veterán
válasz
slashing
#21921
üzenetére
Az E1 cella tartalmazza a mindenkori utolsó sor értékét.
Előfordul, hogy 1-2 sor cellái üresen maradnak a táblázat fölött, akkor az oszlop üres celláinak a számát add hozzá az E1 képletéhez. Ha 2 üres cella van az A oszlop tetején, az E1 képlete =darab2(a:a)+2
Figyelem! Ha üres cellák is vannak az A oszlopban, az E1 nem az utolsó kitöltött cella sorszámát adja!
-
Delila_1
veterán
válasz
DasBoot
#21919
üzenetére
Talán így érthetőbb:
Ha jobb(g10;1)<>„k” ÉS jobb(g10,1)<>„M” (nincs prefixum a G10 végén)
akkor a cella értéke legyen g10*2*PI()
Ellenkező esetben
ha jobb(g10;1)=”k”
akkor a cella értéke legyen bal(g10;hossz(g10)-1)*2*PI()*1000
ellenkező esetben (itt már csak M lehet az utolsó karakter)
a cella értéke legyen bal(g10;hossz(g10)-1)*2*PI()*1000000
feltétel vége
Feltétel végeLehet még egy halom hiba, például nincs levédve az ellen, ha valaki a szám után egy J karaktert visz be, vagy akár egy szóközt.
-
Delila_1
veterán
válasz
csenor
#21907
üzenetére
A makró, amit egy gombhoz rendelhetsz, az Eredmények lap X oszlopába beírja a csapatok nevét, az Y-ba a pontszámot, mindezt csökkenő sorrendben.
Sub Pont()
Dim sor As Long, usor As Long
Sheets("Eredmények").Select
Columns(13).Copy
Range("X1").PasteSpecial xlPasteValues
Columns(21).Copy
Range("Y1").PasteSpecial xlPasteValues
usor = Range("X" & Rows.Count).End(xlUp).Row
For sor = usor To 2 Step -1
If InStr(Cells(sor, "X"), "csoport") Or Cells(sor, "X") = "" Then
Range("X" & sor & ":Y" & sor).Delete
End If
Next
'Rendezés
usor = Range("X" & Rows.Count).End(xlUp).Row
Columns("X:Y").Select
ActiveWorkbook.Worksheets("Eredmények").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Eredmények").Sort.SortFields.Add Key:=Range( _
"Y1:Y" & usor), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Eredmények").Sort
.SetRange Range("X1:Y" & usor)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("X1:Y1").Insert Shift:=xlDown
Range("X1") = "Csapat": Range("Y1") = "Pontszám"
End Sub -
Delila_1
veterán
Küldöm a másolással, és értékbeillesztéssel kiegészített teszt makrót. Írd át a meghajtó betűjelét!
Sub teszt()
Dim Args As TFindFile, usor As Long, WS As Worksheet
Dim Siker As Boolean, i As Long
With Args
'**************** itt a saját meghajtód nevét írd be! *******
.StartFolder = "F:\"
'****************************************************************
.FileName = InputBox("fájlnév vagy része") & "*"
.Extension = "xlsx"
End With
Siker = FindFile(Args:=Args)
Set WS = ActiveWorkbook.Sheets("Munka1")
If Siker Then
For i = 1 To UBound(Args.Findings)
usor = WS.Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks.Open FileName:=Args.Findings(i)
Range("Munka1!A1:L7").Copy
WS.Range("A" & usor).PasteSpecial xlPasteValues
ActiveWorkbook.Close
Next
Else
MsgBox "Nincs találat."
End If
If Args.ErrorCount > 0 Then
MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
End If
End Sub -
-
-
Delila_1
veterán
válasz
bteebi
#21878
üzenetére
Sub osszeir()
Dim lap%, tartomany As Range, CV As Range
Dim oszlop As Integer, betu As String
For lap% = 1 To Sheets.Count
If Sheets(lap%).Name <> "osszeir" Then
Sheets(lap%).Select
Range("A5").Select
Set tartomany = Selection.CurrentRegion
For Each CV In tartomany
Debug.Print CV.Address
If CV.Interior.ColorIndex = 3 Then
betu = Cells(6, CV.Column)
If CV.Column Mod 2 = 0 Then
oszlop = CV.Column
Else
oszlop = CV.Column - 1
End If
Sheets("osszeir").Range(CV.Address) = "0" & Cells(5, oszlop) & "-" & _
betu & "-" & Cells(CV.Row, 1) & "h"
End If
Next
End If
Next
Sheets("osszeir").Select
End Sub -
Delila_1
veterán
Nem tudtam megírni, egy régi kedves barátom segített ki.
A teszt makróban a .StartFolder = "F:\" sorban írd át a meghajtó nevét a sajátodra, majd a ciklusban a jelzett részbe tedd be a másolást, és a megnyitott fájl bezárását. Ezt makrót kell indítanod. Bekéri a keresendő fájlok nevének azt a részét, ami közös, a példád szerint ez valami. A státuszsorban megjelennek a mappák, almappák, ahol a valami kezdetű fájlneveket keresi.
Public Type TFindFile
StartFolder As String
FileName As String
Extension As String
Findings() As String
ErrorCount As Long
End TypeFunction FindFile(Args As TFindFile) As Boolean
Dim Folders() As String, CurrentFolder As String, FolderLevel As Long
Dim FN As String, LookUpName As String
Dim i As Long, Maxi As Long, Mini As Long, FileFound As Boolean
Dim Rng As Range
With Args
ChDrive Left(.StartFolder, 1)
If Right(.StartFolder, 1) <> "\" Then .StartFolder = .StartFolder & "\"
ReDim Folders(1)
Folders(1) = .StartFolder
FolderLevel = UBound(Split(.StartFolder, "\"))
LookUpName = .FileName & "." & .Extension
End With
ReDim Args.Findings(0)
Mini = 1
On Error GoTo hiba
Do
Maxi = UBound(Folders)
For i = Mini To Maxi
FN = Dir(Folders(i) & LookUpName, vbNormal)
While Not FN = ""
FileFound = True
ReDim Preserve Args.Findings(UBound(Args.Findings) + 1)
Args.Findings(UBound(Args.Findings)) = Folders(i) & FN
FN = Dir()
Wend
If UBound(Split(Folders(i), "\")) = FolderLevel Then
FN = Dir(Folders(i) & "*.*", vbDirectory)
While Not FN = ""
If (FN <> ".") And (FN <> "..") Then
If (GetAttr(Folders(i) & FN) And vbDirectory) <> 0 Then
FN = Folders(i) & FN & "\"
ReDim Preserve Folders(UBound(Folders) + 1)
Folders(UBound(Folders)) = FN
Application.StatusBar = FN
End If
End If
FN = Dir()
Wend
End If
DoEvents
Next
Mini = Maxi
FolderLevel = FolderLevel + 1
Loop Until Maxi = UBound(Folders)
If FileFound Then FindFile = True
Application.StatusBar = False
Exit Function
hiba:
Set Rng = Sheets("Hibák").Range("A" & Rows.Count).End(xlUp).Offset(1)
With Rng
.Value = Folders(i)
.Offset(, 1) = FN
.Offset(, 2) = Err.Description
.Offset(, 3) = Err.Number
End With
Args.ErrorCount = Args.ErrorCount + 1
Resume Next
End FunctionSub teszt()
Dim Args As TFindFile
Dim Siker As Boolean, i As Long
With Args
'**************** itt a saját meghajtód nevét írd be! *******
.StartFolder = "F:\"
'****************************************************************
.FileName = InputBox("fájlnév vagy része") & "*"
.Extension = "xlsx"
End With
Siker = FindFile(Args:=Args)
If Siker Then
For i = 1 To UBound(Args.Findings)
Workbooks.Open FileName:=Args.Findings(i)
'****************************************************************
' ide jön a másolás, majd a behívott fájl bezárása
'****************************************************************
Next
Else
MsgBox "Nincs találat."
End If
If Args.ErrorCount > 0 Then
MsgBox Args.ErrorCount & " probléma merült fel, lásd Hibák munkalap."
End If
End Sub
Új hozzászólás Aktív témák
Hirdetés
Fferi50- Azonnali VGA-s kérdések órája
- Kerékpárosok, bringások ide!
- Futás, futópályák
- Steam topic
- Eredeti játékok OFF topik
- A fociról könnyedén, egy baráti társaságban
- Ivqkzy-: 2. gépem
- EA Sports WRC '23
- QWERTY billentyűzet és másodlagos kijelző is lesz a Titan 2-ben
- Fejhallgató erősítő és DAC topik
- További aktív témák...
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Microsoft licencek KIVÉTELES ÁRON AZONNAL - UTALÁSSAL IS AUTOMATIKUS KÉZBESÍTÉS - Windows és Office
- Assassin's Creed Shadows Collector's Edition PC
- Bontatlan - BATTLEFIELD 1 Collectors Edition - Játékszoftver nélkül
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Bomba ár! HP EliteBook 840 G2 - i5-5GEN I 8GB I 256GB SSD I 14" HD+ I Cam I W10 I Garancia!
- ÁRGARANCIA! Épített KomPhone Ryzen 7 9800X3D 32/64GB RAM RTX 5070 12GB GAMER PC termékbeszámítással
- ÁRGARANCIA!Épített KomPhone Ryzen 7 5700X 16/32/64GB RAM RTX 3060 12GB GAMER PC termékbeszámítással
- ÁRGARANCIA!Épített KomPhone i5 14600KF 32/64GB DDR5 RTX 4070Ti Super GAMER PC termékbeszámítással
- Samsung Galaxy S21 Ultra 256GB, Kártyafüggetlen, 1 Év Garanciával
Állásajánlatok
Cég: PCMENTOR SZERVIZ KFT.
Város: Budapest
Cég: CAMERA-PRO Hungary Kft
Város: Budapest