- sziku69: Szólánc.
- sziku69: Fűzzük össze a szavakat :)
- Luck Dragon: Asszociációs játék. :)
- gban: Ingyen kellene, de tegnapra
- pr1mzejEE: Viszlát CoD2, CoD4, CS:GO!
- Magga: PLEX: multimédia az egész lakásban
- D1Rect: Nagy "hülyétkapokazapróktól" topik
- eBay-es kütyük kis pénzért
- bitpork: Phautós tali a Balcsinál 2025 Augusztus 2 napján (szombat)
- Brogyi: CTEK akkumulátor töltő és másolatai
Hirdetés
Talpon vagyunk, köszönjük a sok biztatást! Ha segíteni szeretnél, boldogan ajánljuk Előfizetéseinket!
-
LOGOUT
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
Topikgazda
válasz
alevan #26181 üzenetére
Szia!
A következő megoldást javaslom:
Sub fajlmasolo()
' A makró legyen a Master fileban, amit makróbarát fájlként kell a művelet elindítása előtt elmenteni!
' Így a Master.xlsm legyen a forrásfájlokkal egy mappában, ez a mappa mindegy, hogy hol van!.
Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear ' a munkalap tartalmát kitöröljük
'Hol vannak a fájlok
Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx") 'Ha régi formátumban vannak, akkor .xls-re írd át.
xx = 1 'ez az első fájl helye - az első oszlop
'Menjen végig minden fájlon
Do While Len(Filename) > 0
'NEM KELL Megnyitni a forrást!!!
Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!B2" 'Sheet1 helyére azt a munkalapnevet kell írnod, ahol az adatok vannak a forrásfájlban.
Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!C8"
Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!B15"
' itt folytatod a kitöltést a fentiek szerint
xx = xx + 1 ' vesszük a következő oszlopba
Filename = Dir() 'a következő fájlt
Loop
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value ' a képleteket átváltjuk értékre
MsgBox "A másolásnak vége!", vbInformation
End SubMakrót az Alt+F11 után "feltűnő" VBA ablakba tudsz másolni. A menüből ki kell választanod az Insert - Module opciót. Ezután tudod a modulba bemásolni.
A forrásfájlokat utána kitörölheted - vagy az újakkal felülírhatod és ismételten lefuttatod a makrót.
Üdv.
-
Louro
őstag
válasz
alevan #26181 üzenetére
Szia,
egy gyors, esti fusimunka, de hátha használható. Ha nem megy a makrózás, akkor bocsi. Feltételezek egy kisebb hozzáértést
Főleg az adatmásolásnál lehet hasznos, bár pici logikával hamar megvan, hogy hogyan lehet A-ból B-be másolgatni.
A lentit direkt úgy csináltam, hogy a forrásokat kimented egy mappába, így az eredetik érintetlenek maradnak. A fájlokat át se kell nevezni. A lényeg, hogy .xlsx legyen a kiterjesztésük. Azokat mind bedolgozza.
SUB fajlfeldolgozo()
'A Master.xlsx legyen az asztalon.
'A forrásfájlokat másold az Asztal/Forrás mappába ;)
'Így nem kell aggódni, ha 1001 forrás van.
Dim Filename, Pathname As String
Dim SourceWorkbook As Workbook
Dim LeadFinalMsgBox As Boolean
'Hol vannak a fájlok
Pathname = ActiveWorkbook.Path & "\Forrás\"
'Ha régi formátumban vannak, akkor .xls-re írd át.
Filename = Dir(Pathname & "*.xlsx")
'Menjen végig minden fájlon
Do While Len(Filename) > 0
'Megnyitni a forrást
Workbooks.Open(Filename)
'Itt jön a másolgatás.
Range("B2").Select
Selection.Copy
Workbooks("Master.xlsx").Worksheets("Sheet1").Range(Cells(ActiveSheet.Usedrange.Rows.Count,1)).PasteSpecial xlPasteValues
Range("C8").Select
Selection.Copy
Workbooks("Master.xlsx").Worksheets("Sheet1").Range(Cells(ActiveSheet.Usedrange.Rows.Count,2)).PasteSpecial xlPasteValues
'itt akár elegánsan ciklussal is meglehetne csinálni.
'Forrásfájl törlése
Kill Pathname & Filename
'Hol vannak a fájlok
Filename = Dir(Pathname & "*.xlsx")
Loop
End SUB
Új hozzászólás Aktív témák
- Milyen autót vegyek?
- Need for Speed: Rivals
- Battlefield 1
- Bemutatkozott a Poco X7 és X7 Pro
- Redmi Note 10S - egy a sok közül
- Milyen légkondit a lakásba?
- EAFC 25
- Kávé kezdőknek - amatőr koffeinisták anonim klubja
- Steam, GOG, Epic Store, Humble Store, Xbox PC Game Pass, Origin Access, uPlay+, Apple Arcade felhasználók barátságos izgulós topikja
- sziku69: Szólánc.
- További aktív témák...
- Windows 10 11 Pro Office 19 21 Pro Plus Retail kulcs 1 PC Mac AKCIÓ! Automatikus 0-24
- Több mint 70.000 eladott szoftverlicenc
- Akciós Windows 10 pro + Office 2019 professional plus csomag AZONNALI SZÁLLÍTÁS
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Kaspersky, BitDefender, Avast és egyéb vírusírtó licencek a legolcsóbban, egyenesen a gyártóktól!
- Bomba Ár! Dell Latitude 3190 - Intel N4120 I 4GB I 128GB SSD I 11,6" HD I Cam I W11 I Garancia!
- Telefon felvásárlás!! iPhone X/iPhone Xs/iPhone XR/iPhone Xs Max
- PS Plus előfizetések
- Bomba ár! Lenovo ThinkPad T460 - i5-6GEN I 8GB I 256GB SSD I 14" FHD I Cam I W10 I Garancia!
- BESZÁMÍTÁS! LG UltraGear 27GL850-B 144Hz QHD 1ms monitor garanciával hibátlan működéssel
Állásajánlatok
Cég: FOTC
Város: Budapest