Note: The other languages of the website are Google-translated. Back to English

Hogyan lehet végigpörgetni egy könyvtár fájljait és másolni az adatokat az Excel törzslapjába?

Feltéve, hogy egy mappában több Excel munkafüzet van, és szeretné végiggörgetni ezeket az Excel fájlokat, és adatokat másolni az azonos nevű munkalapok meghatározott tartományából az Excel fő munkalapjába, mit tehet? Ez a cikk részletesen bemutatja az elérésének módját.

Húzza végig a könyvtár fájljait, és másolja az adatokat egy VBA kóddal ellátott törzslapra


Húzza végig a könyvtár fájljait, és másolja az adatokat egy VBA kóddal ellátott törzslapra

Ha az A1: D4 tartományban megadott adatokat át szeretné másolni egy adott mappában lévő munkafüzetek összes 1. lapjáról egy törzslapra, akkor tegye a következőket.

1. A munkafüzetben létrehoz egy fő munkalapot, nyomja meg a gombot más + F11 billentyűk megnyitásához Microsoft Visual Basic for Applications ablak.

2. Ban,-ben Microsoft Visual Basic for Applications ablakban kattintson betétlap > Modulok. Ezután másolja a VBA kód alatt a kód ablakba.

VBA kód: egy mappában lévő fájlok közötti áttekintés és az adatok másolása egy törzslapra

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Megjegyzések:

1). A kódban „A1: D4"És"Sheet1”Azt jelenti, hogy az összes 1. lap A4: D1 tartományába eső adatokat átmásolja a törzslapra. És „Új lap”Az új létrehozott törzslap neve.
2). Az adott mappában lévő Excel fájloknak nem szabad megnyílniuk.

3. megnyomni a F5 gombot a kód futtatásához.

4. A nyílásban Tallózás ablakban, válassza ki a mappát, amely tartalmazza azokat a fájlokat, amelyeken keresztül végighúzza, majd kattintson a gombra OK gomb. Lásd a képernyőképet:

Ezután létrehoz egy „Új lap” nevű fő munkalapot az aktuális munkafüzet végén. A kiválasztott mappában található összes 1. lap D4 tartományának adatai pedig a munkalapon vannak felsorolva.


Kapcsolódó cikkek:


A legjobb irodai termelékenységi eszközök

A Kutools for Excel megoldja a legtöbb problémát, és 80% -kal növeli a termelékenységet

  • újrafelhasználás: Gyorsan helyezze be összetett képletek, diagramok és bármi, amit korábban használt; Cellák titkosítása jelszóval; Levelezőlista létrehozása és e-maileket küldeni ...
  • Szuper Formula Bár (könnyedén szerkeszthet több szöveget és képletet); Olvasás elrendezés (könnyen olvasható és szerkeszthető nagyszámú cella); Beillesztés a Szűrt tartományba...
  • Cellák / sorok / oszlopok egyesítése az adatok elvesztése nélkül; Osztott cellák tartalma; Kombinálja a duplikált sorokat / oszlopokat... megakadályozza az ismétlődő cellákat; Hasonlítsa össze a tartományokat...
  • Válassza a Másolat vagy az Egyedi lehetőséget Sorok; Válassza az Üres sorok lehetőséget (az összes cella üres); Super Find és Fuzzy Find sok munkafüzetben; Véletlenszerű kiválasztás ...
  • Pontos másolás Több cella a képletreferencia megváltoztatása nélkül; Automatikus referenciák létrehozása több lapra; Helyezze be a golyókat, Jelölőnégyzetek és még sok más ...
  • Kivonat szöveg, Szöveg hozzáadása, Eltávolítás pozíció szerint, Hely eltávolítása; Hozz létre és nyomtasson személyhívó részösszegeket; Konvertálás a cellatartalom és a megjegyzések között...
  • Szuper szűrő (mentse el és alkalmazza a szűrősémákat más lapokra); Haladó rendezés hónap / hét / nap, gyakoriság és egyebek szerint; Speciális szűrő félkövér, dőlt betűvel ...
  • Kombinálja a munkafüzeteket és a munkalapokat; Táblázatok egyesítése kulcsoszlopok alapján; Az adatok felosztása több lapra; Kötegelt konvertálás xls, xlsx és PDF...
  • Több mint 300 hatékony funkció. Támogatja az Office / Excel 2007-2021 és 365 verziókat. Minden nyelvet támogat. Könnyű üzembe helyezés vállalatában vagy szervezetében. Teljes funkciók 30 napos ingyenes próbaverzió. 60 napos pénzvisszafizetési garancia.
kte lap 201905

Az Office fül a füles felületet hozza az Office-ba, és sokkal könnyebbé teszi a munkáját

  • Füles szerkesztés és olvasás engedélyezése Wordben, Excelben és PowerPointban, Publisher, Access, Visio és Project.
  • Több dokumentum megnyitása és létrehozása ugyanazon ablak új lapjain, mint új ablakokban.
  • 50% -kal növeli a termelékenységet, és naponta több száz kattintással csökkenti az egér kattintását!
officetab alja
A megjegyzések rendezése szerint
Hozzászólások (20)
Még nincs értékelés. Legyen Ön az első, aki értékel!
A weboldal moderátora ezt a megjegyzést minimalizálta
köszönöm a vba kódot! Tökéletesen működik! Szeretném tudni, hogy mi a kód, ha helyette ÉRTÉKKÉNT kell beillesztenem? Thx előre is!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Lai Ling!
A következő kód segíthet a probléma megoldásában. Köszönjük észrevételét.

Sub Merge2MultiSheets()
Dim xrg mint tartomány
Dim xSelItem As Variant
Dim xFileDlg mint FileDialog
Dim xFileName, xSheetName, xRgStr karakterláncként
Dim xBook, xWorkBook munkafüzetként
Dim xSheet munkalapként
On Error Resume Next
Application.DisplayAlerts = Hamis
Application.EnableEvents = Hamis
Application.ScreenUpdating = Hamis
xSheetName = "1. lap"
xRgStr = "A1:D4"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Az xFileDlg segítségével
Ha .Show = -1 Akkor
xSelItem = .SelectedItems.Item(1)
Állítsa be az xWorkBook = ThisWorkbookot
Set xSheet = xWorkBook.Sheets("Új munkalap")
Ha az xSheet Semmi akkor
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Új munkalap"
Set xSheet = xWorkBook.Sheets("Új munkalap")
Ha véget
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Ha xFileName = "" Akkor lépjen ki a Sub
Addig csináld, amíg xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Eltolás(1, 0)
xFileName = Dir()
xBook.Close
Hurok
Ha véget
Vége
Állítsa be az xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Igaz
xRg.UseStandardWidth = Igaz
Application.DisplayAlerts = Igaz
Application.EnableEvents = Igaz
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, köszönöm a kódot. Kérem, tudassa velem, hogyan tudom megadni az Excel fájl nevét, amelyből az adattartományt másolták? Ez nagy segítség lenne!

Köszönöm.
A weboldal moderátora ezt a megjegyzést minimalizálta
Helló,

Köszönöm a bemutatót.

Hogyan csinálnám: Csak másolja ki az „1. ​​munkalap” sorát az „összes” sor értékeivel, és illessze be a [fájlnév] elemet az „Új munkalap” nevű fő munkalapra. Az Összes sor megjegyzése az egyes munkalapokon eltérő lehet.

Például:
Fájl1: Lap1
Col1, Col2, Colx
1,2,15
Eredmény,10,50

Fájl2: Lap1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Eredmény,300,500

MasterFile: "Új lap":
fájl1, 10, 50
fájl2, 300, 500
A weboldal moderátora ezt a megjegyzést minimalizálta
Sziasztok, ez remekül működik. Van mód úgy változtatni, hogy csak az értékeket húzzuk át, és ne a képletet?
Kösz!!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Trish
A következő kód segíthet a probléma megoldásában. Köszönjük észrevételét.

Sub Merge2MultiSheets()
Dim xrg mint tartomány
Dim xSelItem As Variant
Dim xFileDlg mint FileDialog
Dim xFileName, xSheetName, xRgStr karakterláncként
Dim xBook, xWorkBook munkafüzetként
Dim xSheet munkalapként
On Error Resume Next
Application.DisplayAlerts = Hamis
Application.EnableEvents = Hamis
Application.ScreenUpdating = Hamis
xSheetName = "1. lap"
xRgStr = "A1:D4"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
Az xFileDlg segítségével
Ha .Show = -1 Akkor
xSelItem = .SelectedItems.Item(1)
Állítsa be az xWorkBook = ThisWorkbookot
Set xSheet = xWorkBook.Sheets("Új munkalap")
Ha az xSheet Semmi akkor
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Új munkalap"
Set xSheet = xWorkBook.Sheets("Új munkalap")
Ha véget
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Ha xFileName = "" Akkor lépjen ki a Sub
Addig csináld, amíg xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Eltolás(1, 0)
xFileName = Dir()
xBook.Close
Hurok
Ha véget
Vége
Állítsa be az xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = Igaz
xRg.UseStandardWidth = Igaz
Application.DisplayAlerts = Igaz
Application.EnableEvents = Igaz
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia, továbbra is a képleteket húzza, nem az értékeket, ezért #REF hibát ad. Tudom, hogy valahol szüksége lehet egy .PasteSpecial xlPasteValues-ra, de nem tudom, hol. Tud segíteni? Kösz!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Köszönöm ezt.


Hogyan vehetem fel a kódot az összes mappán és almappán való áthurkoláshoz és a fenti másolás végrehajtásához?


Köszönjük!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia! Ez a kód tökéletes arra, amit szeretnék elérni.

Van mód az összes mappában és almappában való hurokra, és a másolás végrehajtására?


Köszönjük!
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia! Ez a kód nagyon jól működik minden fájl első 565 sorában, de az azt követő sorok átfedik a következő fájlt.
van megoldás erre?
A weboldal moderátora ezt a megjegyzést minimalizálta
Köszönjük – hogyan lehetne egy munkafüzetben lévő egyes munkalapokról (speciális értékeket) másolni és beilleszteni a fő mesterfájlon belüli külön lapokra?
A weboldal moderátora ezt a megjegyzést minimalizálta
Hogyan lehet a kódolást üresen hagyni, ha a cella üres?
A weboldal moderátora ezt a megjegyzést minimalizálta
nálam a "Sheet1" lap neve megváltozik minden fájlomnál. Például, Tab1, Tab2, Tab3, Tab4...Hogyan állíthatok be egy ciklust, hogy végigfusson egy listán Excelben, és folyamatosan változtassa a "Sheet1" nevet, amíg az mindent át nem fut?
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Nick! Az alábbi VBA-kód segíthet a probléma megoldásában. Kérjük, próbálja meg. Sub LoopThroughFileRename()
„Frissítve az Extendofice által: 2021
Dim xrg mint tartomány
Dim xSelItem As Variant
Dim xFileDlg mint FileDialog
Dim xFileName, xSheetName, xRgStr karakterláncként
Dim xBook, xWorkBook munkafüzetként
Dim xSheet munkalapként
Dim xShs As Sheets
Dim xName As String
Dim xFNum As Integer
On Error Resume Next
Application.DisplayAlerts = Hamis
Application.EnableEvents = Hamis
Application.ScreenUpdating = Hamis
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Tegye az xFileName <> "" közben
Set xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Állítsa be: xShs = xWorkBook.Sheets
Ha xFNum = 1 - xShs.Count
xSheet = xShs.Item(xFNum) beállítása
xName = xSheet.Name
xName = Csere(xName, "lap""Tab") 'Cserélje le a lapot a tabulátorral
xSheet.Name = xName
Következő
xWorkBook.Save
xWorkBook.Close
xFileName = Dir()
Hurok
Application.DisplayAlerts = Igaz
Application.EnableEvents = Igaz
Application.ScreenUpdating = Igaz
End Sub
A weboldal moderátora ezt a megjegyzést minimalizálta
Sziasztok, szeretnék egy kódot 6 különböző munkafüzet adatainak másolásához (egy mappába), amelyekben lapok vannak, az ÚJ MUNKAFÜZET-be. vba-ban
kérlek segítsetek asp
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Paranusha,
A következő cikkben szereplő VBA-parancsfájl több munkafüzetet vagy munkafüzetek meghatározott lapjait kombinálhatja egy fő munkafüzetté. Kérjük, ellenőrizze, hogy segíthet-e.
Hogyan kombinálhatunk több munkafüzetet egyetlen fő munkafüzetté Excelben?
A weboldal moderátora ezt a megjegyzést minimalizálta
Olá bom dia.
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes e não estão configuradas corretamente para impressão. Pode me enviar um códgo de VBA que automatize essas impressões? Me ajudaria muito, obrigada.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Maria Soares!
Kérjük, ellenőrizze, hogy a következő bejegyzésben található VBA-kód segíthet-e.
Hogyan nyomtathat több munkafüzetet az Excel programban?
A weboldal moderátora ezt a megjegyzést minimalizálta
Az én forgatókönyvem hasonló, kivéve, hogy minden fájlban több munkalap van, amelyek mindegyike más néven, de a fájlok között konzisztens. Van mód ennek a kódnak a hurkolására, hogy a fájlokban lévő adatokat másolja, és beillessze (értékeket) a fő munkafüzet adott lapneveire? A mesterben a lapnevek ugyanazok, mint a fájlokban. Át akarom nézni őket. Ezenkívül az egyes lapokon lévő adatok mennyisége változhat, ezért az egyes lapokon lévő adatokat valami ilyesmivel kell kiválasztanom:

Tartomány("A1").Válassza ki
Tartomány(Kiválasztás, Kiválasztás.Vége(xlLe)).Válassza ki
Tartomány(Kiválasztás, Kijelölés.Vége(xlToJobbra)).Kiválasztás


A fájllapnevek: Adományozás, Szolgáltatások, Biztosítás, Autó, Egyéb költségek stb...

Előre is köszönöm.
A weboldal moderátora ezt a megjegyzést minimalizálta
Szia Andrew Shahan!
A következő VBA-kód megoldhatja a problémát. A kód futtatása és egy mappa kiválasztása után a kód automatikusan megegyezik a munkalappal név szerint, és beilleszti az adatokat a fő munkafüzet azonos nevű munkalapjába.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Még senki sem írt megjegyzést
Hagyja meg észrevételeit
Feladás vendégként
×
Értékeld ezt a bejegyzést:
0   Karakterek
Javasolt helyek

Kövess minket

Copyright © 2009 - www.extendoffice.com. | Minden jog fenntartva. Powered by ExtendOffice. | Oldaltérkép
A Microsoft és az Office logó a Microsoft Corporation védjegyei vagy bejegyzett védjegyei az Egyesült Államokban és / vagy más országokban.
Sectigo SSL védi