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

Hoe bestanden in een directory doorlopen en gegevens naar een hoofdblad in Excel kopiëren?

Stel dat er meerdere Excel-werkmappen in een map staan ​​en u al deze Excel-bestanden wilt doorlopen en gegevens uit een opgegeven reeks werkbladen met dezelfde naam wilt kopiëren naar een hoofdwerkblad in Excel, wat kunt u dan doen? Dit artikel introduceert een methode om dit in detail te bereiken.

Loop door bestanden in een directory en kopieer gegevens naar een masterblad met VBA-code


Loop door bestanden in een directory en kopieer gegevens naar een masterblad met VBA-code


Als u gespecificeerde gegevens in bereik A1: D4 van alle werkbladen 1 in een bepaalde map naar een hoofdblad wilt kopiëren, doet u het volgende.

1. In de werkmap maakt u een hoofdwerkblad, druk op de anders + F11 toetsen om de te openen Microsoft Visual Basic voor toepassingen venster.

2. In de Microsoft Visual Basic voor toepassingen venster klikt Invoegen > Module. Kopieer vervolgens onderstaande VBA-code naar het codevenster.

VBA-code: loop door bestanden in een map en kopieer gegevens naar een hoofdblad

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

Opmerking::

1). In de code, "A1: D4"En"Sheet1”Betekent dat gegevens in het bereik A1: D4 van alle Sheet1 naar het masterblad worden gekopieerd. En "Nieuw blad”Is de naam van het nieuw aangemaakte basisblad.
2). De Excel-bestanden in de specifieke map mogen niet worden geopend.

3. druk de F5 sleutel om de code uit te voeren.

4. In de opening Blader Selecteer de map met de bestanden die u wilt doorlopen en klik op het OK knop. Zie screenshot:

Vervolgens wordt aan het einde van de huidige werkmap een hoofdwerkblad met de naam "Nieuw blad" gemaakt. En gegevens in het bereik A1: D4 van alle Sheet1 in de geselecteerde map worden weergegeven in het werkblad.


Gerelateerde artikelen:


De beste tools voor kantoorproductiviteit

Kutools voor Excel lost de meeste van uw problemen op en verhoogt uw productiviteit met 80%

  • visfuik: Snel invoegen complexe formules, grafieken en alles wat je eerder hebt gebruikt; Versleutel cellen met wachtwoord; Maak een mailinglijst en stuur e-mails ...
  • Super Formula-balk (bewerk eenvoudig meerdere regels tekst en formule); Lay-out lezen (gemakkelijk grote aantallen cellen lezen en bewerken); Plakken in gefilterd bereik...
  • Voeg cellen / rijen / kolommen samen zonder gegevens te verliezen; Gespleten cellen inhoud; Combineer dubbele rijen / kolommen... Voorkom dubbele cellen; Vergelijk Ranges...
  • Selecteer Dupliceren of Uniek Rijen; Selecteer lege rijen (alle cellen zijn leeg); Super zoeken en fuzzy zoeken in veel werkboeken; Willekeurige selectie ...
  • Exacte kopie Meerdere cellen zonder de formuleverwijzing te wijzigen; Maak automatisch verwijzingen naar meerdere bladen; Plaats kogels, Selectievakjes en meer ...
  • Extraheer tekst, Tekst toevoegen, Verwijderen op positie, Ruimte verwijderen; Paging-subtotalen maken en afdrukken; Converteren tussen celinhoud en opmerkingen...
  • Super filter (bewaar en pas filterschema's toe op andere bladen); Geavanceerd sorteren per maand / week / dag, frequentie en meer; Speciaal filter door vet, cursief ...
  • Combineer werkmappen en werkbladen; Tabellen samenvoegen op basis van sleutelkolommen; Gegevens splitsen in meerdere bladen; Batch Converteer xls, xlsx en PDF...
  • Meer dan 300 krachtige functies. Ondersteunt Office / Excel 2007-2019 en 365. Ondersteunt alle talen. Eenvoudig te implementeren in uw onderneming of organisatie. Gratis proefperiode van 30 dagen met volledige functies. 60 dagen geld-terug-garantie.
kte tabblad 201905

Office-tabblad Brengt een interface met tabbladen naar Office en maakt uw werk veel gemakkelijker

  • Schakel bewerken en lezen met tabbladen in Word, Excel, PowerPoint in, Publisher, Access, Visio en Project.
  • Open en maak meerdere documenten in nieuwe tabbladen van hetzelfde venster in plaats van in nieuwe vensters.
  • Verhoogt uw productiviteit met 50% en vermindert elke dag honderden muisklikken!
officetab onderkant
Comments (14)
Nog geen beoordelingen. Beoordeel als eerste!
Deze opmerking is gemaakt door de moderator op de site
bedankt voor de vba-code! Het werkt perfect! Zou graag willen weten wat de code is als ik in plaats daarvan ALS WAARDE moet Plakken? Thx alvast!
Lai Ling
Deze opmerking is gemaakt door de moderator op de site
Hallo Lai Ling,
De volgende code kan u helpen het probleem op te lossen. Bedankt voor je reactie.

Sub Merge2MultiSheets()
Dim xRg als bereik
Dim xSelItem als variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook als werkboek
Dim xSheet als werkblad
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Blad1"
xRgStr = "A1:D4"
Stel xFileDlg = Application.FileDialog (msoFileDialogFolderPicker) in
Met xFileDlg
Als .Toon = -1 Dan
xSelItem = .SelectedItems.Item(1)
Stel xWorkBook = ThisWorkbook in
Stel xSheet = xWorkBook.Sheets ("Nieuw blad") in
Als xSheet niets is, dan
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nieuw blad"
Stel xSheet = xWorkBook.Sheets ("Nieuw blad") in
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Als xFileName = "" Sub afsluiten
Doen tot xFileName = ""
Stel xBook = Workbooks.Open in (xSelItem & "\" & xFileName)
Stel xRg = xBook.Werkbladen (xBladnaam).Bereik (xRgStr) in
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xBestandsnaam = Dir()
xBoek.Sluiten
lus
End If
Eindigt met
Stel xRg = xSheet.UsedRange in
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
crystal
Deze opmerking is gemaakt door de moderator op de site
Hallo, bedankt voor de code. Kunt u mij alstublieft laten weten hoe ik de Excel-bestandsnaam kan opnemen waaruit het gegevensbereik is gekopieerd? Dit zou een grote hulp zijn!

Dank je.
Paul Gill
Deze opmerking is gemaakt door de moderator op de site
Hallo,

Bedankt voor de bijles.

Hoe zou ik: Kopieer alleen de rij in "Blad1" met waarden uit de "totaal" rij en plak met [bestandsnaam] in het hoofdwerkblad met de naam "Nieuw blad". Het noteren van de rij met Totaal kan in elk werkblad anders zijn.

Bijvoorbeeld:
Bestand1: Blad1
Col1,Col2,Colx
1,2,15
Resultaat,10,50

Bestand2: Blad1
Col1,Col2,Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Resultaat,300,500

MasterFile: "Nieuw blad":
bestand1, 10, 50
bestand2, 300, 500
Robertson
Deze opmerking is gemaakt door de moderator op de site
Hallo daar, Dit werkt geweldig. Is er een manier om te veranderen om gewoon de waarden over te nemen en niet de formule?
Bedankt!!
Trish
Deze opmerking is gemaakt door de moderator op de site
Hallo Trish,
De volgende code kan u helpen het probleem op te lossen. Bedankt voor je reactie.

Sub Merge2MultiSheets()
Dim xRg als bereik
Dim xSelItem als variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook als werkboek
Dim xSheet als werkblad
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "Blad1"
xRgStr = "A1:D4"
Stel xFileDlg = Application.FileDialog (msoFileDialogFolderPicker) in
Met xFileDlg
Als .Toon = -1 Dan
xSelItem = .SelectedItems.Item(1)
Stel xWorkBook = ThisWorkbook in
Stel xSheet = xWorkBook.Sheets ("Nieuw blad") in
Als xSheet niets is, dan
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nieuw blad"
Stel xSheet = xWorkBook.Sheets ("Nieuw blad") in
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Als xFileName = "" Sub afsluiten
Doen tot xFileName = ""
Stel xBook = Workbooks.Open in (xSelItem & "\" & xFileName)
Stel xRg = xBook.Werkbladen (xBladnaam).Bereik (xRgStr) in
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
xBestandsnaam = Dir()
xBoek.Sluiten
lus
End If
Eindigt met
Stel xRg = xSheet.UsedRange in
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
crystal
Deze opmerking is gemaakt door de moderator op de site
Hallo, het trekt nog steeds de formules, niet de waarden, dus het geeft me een #REF-fout. Ik weet dat het misschien ergens een .PasteSpecial xlPasteValues ​​nodig heeft, maar ik weet niet waar. Kun je helpen? Bedankt!
Luisa
Deze opmerking is gemaakt door de moderator op de site
Hoi Bedankt hiervoor.


Hoe voeg ik de code toe om door alle mappen en submappen te bladeren en de bovenstaande kopie uit te voeren?


Bedankt!
Dan
Deze opmerking is gemaakt door de moderator op de site
Hallo - Deze code is perfect voor wat ik probeer te bereiken.

Is er een manier om door alle mappen en submappen te bladeren en de kopie uit te voeren?


Bedankt!
Dan Tran
Deze opmerking is gemaakt door de moderator op de site
Hallo - Deze code werkt heel goed voor de eerste 565 regels voor elk bestand, maar alle regels daarna worden overlapt door het volgende bestand.
is er een manier om dit op te lossen?
Alexander Høgh
Deze opmerking is gemaakt door de moderator op de site
Dank u - hoe zou men (speciale waarden) van elk werkblad in een werkmap kunnen kopiëren en plakken in afzonderlijke bladen in een hoofdhoofdbestand?
Ouen A
Deze opmerking is gemaakt door de moderator op de site
hoe zorg je ervoor dat de code leeg blijft als de cel leeg is?
John
Deze opmerking is gemaakt door de moderator op de site
voor mij verandert de naam van het tabblad "Blad1" voor elk van mijn bestanden. Bijvoorbeeld Tab1, Tab2, Tab3, Tab4 ... Hoe kan ik een lus instellen om door een lijst in Excel te lopen en de naam "Blad1" blijven veranderen totdat deze alles doorloopt?
Nick
Deze opmerking is gemaakt door de moderator op de site
Hallo Nick, De onderstaande VBA-code kan u helpen het probleem op te lossen. Probeer het alsjeblieft. Sub LoopThroughFileRename()
'Bijgewerkt door Extendofice 2021/12/31
Dim xRg als bereik
Dim xSelItem als variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook als werkboek
Dim xSheet als werkblad
Dim xShs als bladen
Dim xName als string
Dim xFNum als geheel getal
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Stel xFileDlg = Application.FileDialog (msoFileDialogFolderPicker) in
xFileDlg.Toon
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Do While xFileName <> ""
Stel xWorkBook = Workbooks.Open in (xSelItem & "\" & xFileName)
Stel xShs = xWorkBook.Sheets in
Voor xFNum = 1 Tot xShs.Count
Stel xSheet = xShs.Item (xFNum) in
xNaam = xBlad.Naam
xNaam = Vervang(xNaam, "vel''Tab") 'Blad vervangen door Tab'
xBlad.Naam = xNaam
volgende
xWorkBook.Opslaan
xWorkBook.Sluiten
xBestandsnaam = Dir()
lus
Application.DisplayAlerts = True
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
crystal
Er zijn nog geen reacties geplaatst
Laat uw commentaar
Posten als gast
×
Beoordeel dit bericht:
0  Personages
Voorgestelde locaties