Hirdetés
- Külföldi prepaid SIM-ek itthon
- Fotók, videók mobillal
- Samsung Galaxy Watch (Tizen és Wear OS) ingyenes számlapok, kupon kódok
- Milyen okostelefont vegyek?
- Xiaomi 15 Ultra - kamera, telefon
- Idő előtt felbukkant a Motorola Razr 70: képek, specifikációk és ár is van
- iPhone topik
- VoLTE/VoWiFi
- Sony WF-1000XM6 – ez évi etalon?
- Android alkalmazások - szoftver kibeszélő 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
-
-
#28537
szatocs1981
aktív tag
air
#28536
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 -
Fferi50
Topikgazda
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.
-
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. -
Fferi50
Topikgazda
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.
-
Fferi50
Topikgazda
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
Topikgazda
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
Topikgazda
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.
Új hozzászólás Aktív témák
Hirdetés
Fferi50
- Vírusirtó, Antivirus, VPN kulcsok GARANCIÁVAL!
- Eredeti Microsoft termékek - MEGA Akciók! Windows, Office Pro Plus, Project Pro, Visio Pro stb.
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- The Elder Scrolls Online Imperial Collector s Edition
- ÚJ HP EliteBook 6 G1a Ryzen 5 PRO 230 4.9GHz 16GB DDR5 1TB FHD+ 16:10 már jobbik kijelző, gar 2028
- Lenovo X1 Tablet Gen3 Intel i5 8350U Refurbished - Garancia
- Lenovo ThinkPad T14 Gen1 Intel i5-10310U Refurbished - Garancia
- Samsung Galaxy A25 5G 128GB/6GB/Számlával!
- AKCIÓ! Intel Core i7 6700 4 mag 8 szál processzor garanciával hibátlan működéssel
Állásajánlatok
Cég: Laptopműhely Bt.
Város: Budapest