- Ubisoft Forward 2024 - Az összes bejelentés egy helyen
- UbiForward24 - Jön az Anno 117: Pax Romana
- UbiForward24 - Hosszabb játékmenet videón az Assassin's Creed Shadows
- UbiForward24 - Sztori kiegészítőt kap az Avatar: Frontiers of Pandora
- UbiForward24 - Prince of Persia: The Sands of Time Remake csak 2026-ban
- Ubisoft Forward 2024 - Az összes bejelentés egy helyen
- UbiForward24 - Prince of Persia: The Sands of Time Remake csak 2026-ban
- EAFC 24
- Konzolokról KULTURÁLT módon
- XGS24 - Befutott a Dragon Age: Veilguard új előzetese
- Empire of the Ants - Az év végétől építhetünk saját hangyabirodalmat
- Battlefield 2042
- Forza sorozat (Horizon/Motorsport)
- Diablo IV
- Xbox Series X|S
-
GAMEPOD.hu
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
-
Fferi50
őstag
Szia!
Egyrészt, nem tudom, hogy a Munkafüzetek összehasonlítása és egyesítése menüpont azt csinálja-e amit szeretnél. Másrészt ki lehet tenni ezt is a menüszalagra, a testreszabásnál ki kell választanod, hogy minden parancsot szeretnél látni és akkor egyéni csoportba "át tudod tolni" a menüszalagra is.
Továbbá, mit értesz azon, hogy egyesíteni kellene egyetlen darab fájlba?
Azt, hogy az összes munkafüzetben levő összes munkalapot bele kellene másolni egy db munkafüzetbe,
vagy azt, hogy a munkalapokon levő adatokat valamilyen algoritmus szerint egy db munkafüzetbe össze kellene fésülni (pl. a Munka1 munkalapon levő cellák értéke a legutolsó előfordulás szerint legyen)?Azért nem gondolod Te sem komolyan, hogy különböző verziókban leledző többszáz munkafüzet majd csettintésre átalakul egy munkafüzetté? Meg kell azért bizony dolgozni. Szépen sorban meg kell nyitogatni őket, majd elvégezni rajtuk/velük a szükséges műveletet (átrakni az "örökös" munkafüzetbe) és utána visszazárni.
Ezt egy nem túl nagy makró megcsinálja, ha tudod, hogy mit szeretnél.Üdv.
-
Fferi50
őstag
Szia!
Ez a gomb szerintem csak közös használatú munkafüzeteknél aktív.
Nem egészen világos még mindig: Adott 300+ fájl egy-egy munkalappal különböző számú sorokkal.
Az adott fájlból a munkalapon levő sorokat a "Főfájl" egyetlen munkalapjának az utolsó sorai után kell bemásolni?Mindenesetre jó lenne, ha az összes fájl egy könyvtárban lenne. Akkor lehet egy viszonylag egyszerű makrót írni az összemásolásukra.
Most más dolgom van, de ha visszajövök, segítek, de írd meg lsz. jól értettem-e a feladatot.
Üdv.
-
Fferi50
őstag
Szia!
Próbáld ki a következőt:
Sub osszerako()
Dim hova As Worksheet, fajlneve As String, usor As Long, xx As Integer
Set hova = ActiveSheet
fajlneve = Dir("*.xls*")
Application.EnableEvents = False
Do While fajlneve <> ""
xx = xx + 1
usor = hova.UsedRange.Rows.Count + 1: If usor = 2 Then usor = 1
Workbooks.Open Filename:=fajlneve, ReadOnly:=True
ActiveSheet.UsedRange.Copy Destination:=hova.Cells(usor, 1)
ActiveWorkbook.Close False
fajlneve = Dir()
If xx Mod 10 = 0 Then Application.StatusBar = "Másolva: " & xx & "db fájl!"
Loop
Application.EnableEvents = True
Application.StatusBar = False
MsgBox "A másolásnak vége, kérem, mentse el a fájlt!", vbInformation, "Fájlok összemásolása"
End SubRemélem segít.
Üdv.
-
Fferi50
őstag
Szia!
Elnavigálsz abba a könyvtárba, ahol a fájljaid vannak.
Elindítod az excelt, ami egy új munkafüzettel indít.
Ide összemásolhatod a fájlokat.
Ezután Alt+F11 lenyomásával átmész a VBA project ablakba.
A menüből kiválasztod az insert, azon belül pedig a module pontot.
A megnyilt modullapra bemásolod az alábbi kódot:
Sub osszerako()
Dim hova As Worksheet, fajlneve As String, usor As Long, xx As Integer
Set hova = ActiveSheet
fajlneve = Dir("*.xls*")
Application.EnableEvents = False
Applicaton.ScreenUpdating=False
Do While fajlneve <> ""
xx = xx + 1
usor = hova.UsedRange.Rows.Count + 1: If usor = 2 Then usor = 1
Workbooks.Open Filename:=fajlneve, ReadOnly:=True
ActiveSheet.UsedRange.Copy Destination:=hova.Cells(usor, 1)
ActiveWorkbook.Close False
fajlneve = Dir()
If xx Mod 10 = 0 Then Application.StatusBar = "Másolva: " & xx & "db fájl!"
Loop
Application.EnableEvents = True
Application.ScreenUpdating=True
Application.StatusBar = False
MsgBox "A másolásnak vége, kérem, mentse el a fájlt!", vbInformation, "Fájlok összemásolása"
End SubVisszamész az excel munkalapra (Alt+F11 ismét).
Ezután menü - nézet- makrók megjelenítése. Megjelenik a listában az osszerako. Inditás.
Alul a státusz soron fogod látni a begyűjtött fájlok számát, tizesével nőve.Ha végzett, kapsz egy üzenetet.
Ezután mentés másként művelettel nevezd el a fájlodat, a mentés után bezárhatod.Remélem, sikerülni fog.
Üdv.
-
air
nagyúr
Sajnos csak a próba sikerült, élesben nem megy a dolog.
Nem tudom, hogy az előbb miért annak a könyvtárnak a tartalmát kezdte összemásolni amelyiket valóban kellett, mert most az istennek sem tudom rávenni, hogy azt csinálja, amit én akarok, ne pedig a teljes "Dokumentumok" mappámat.
Tehát továbbra sem tiszta, hogy miként kell elnavigálni a kérdéses mappába.[ Szerkesztve ]
Tintatartó, aligátor, búzavirág, csók, gyalupad, fogpiszkáló
-
Fferi50
őstag
Szia!
Az alábbi kis makrórészletet légy szíves betenni a dim sor után:
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = CurDir()
If .Show Then
ChDir (.SelectedItems(1))
Else
MsgBox "Nem választottál, kilépek a programból!", vbCritical :Exit Sub
End If
End WithÍgy amikor elindítod a programot, kiválaszthatod, hogy melyik könyvtár adatait rakja össze (ez talán jobb is, mintha kívülről navigálnál, mert ez biztosan oda visz, ahova szeretnéd).
Ha nem válaszottál könyvtárat, akkor nem megy tovább.Üdv.
-
szatocs1981
aktív tag
Ez szétszedi az A1-ben lévöt és A2-B2 töl kezdve feltölti.
Pr´báld ki:Sub Split()
Dim txt As String
Dim x As Variant
Dim i As Long
txt = Cells(1, 1).Value
x = Split(txt, ", ")
ReDim y(UBound(x))
For i = 0 To UBound(x)
y(i) = Split(x(i), "(")
Next i
For i = 0 To UBound(x)
y(i)(1) = Replace(y(i)(1), ")", "")
Next i
For i = 0 To UBound(x)
Cells(i + 2, 1).Value = y(i)(0)
Cells(i + 2, 2).Value = y(i)(1)
Next i
End Sub -
poffsoft
addikt
Új hozzászólás Aktív témák
- Intel Core i5 / i7 / i9 "Alder Lake-Raptor Lake/Refresh" (LGA1700)
- Ukrajnai háború
- Ubisoft Forward 2024 - Az összes bejelentés egy helyen
- Milyen légkondit a lakásba?
- Ford topik
- Vodafone mobilszolgáltatások
- Telekom otthoni szolgáltatások (TV, internet, telefon)
- Óra topik
- UbiForward24 - Prince of Persia: The Sands of Time Remake csak 2026-ban
- Túra és kirándulás topic
- További aktív témák...
Állásajánlatok
Cég: Ozeki Kft.
Város: Debrecen