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

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-2021 en 365. Ondersteunt alle talen. Eenvoudig te implementeren in uw onderneming of organisatie. Volledige functies Gratis proefperiode van 30 dagen. 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 honderden muisklikken voor u elke dag!
officetab onderkant
Heb je vragen? Stel ze hier. (20)
Nog geen beoordelingen. Beoordeel als eerste!
Lai Ling
Lai Ling
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!
Antwoorden
Rapport
0
0
crystal
crystal     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 als 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
Ringleiding
End If
Eindigt met
Stel xRg = xSheet.UsedRange in
xRg.ClearFormats
xRg.UseStandardHeight = Waar
xRg.UseStandardWidth = Waar
Application.DisplayAlerts = Waar
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
Antwoorden
Rapport
0
0
Paul Gil
Paul Gil
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.
Antwoorden
Rapport
0
0
Robertson
Robertson
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
Antwoorden
0
0
Trish
Trish
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!!
Antwoorden
0
0
crystal
crystal     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 als 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
Ringleiding
End If
Eindigt met
Stel xRg = xSheet.UsedRange in
xRg.ClearFormats
xRg.UseStandardHeight = Waar
xRg.UseStandardWidth = Waar
Application.DisplayAlerts = Waar
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
Antwoorden
Rapport
0
0
Luisa
Luisa     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!
Antwoorden
0
0
Dan
Dan
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!
Antwoorden
0
0
Dan Tran
Dan Tran
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!
Antwoorden
Rapport
0
0
Alexander Høgh
Alexander Høgh
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?
Antwoorden
0
0
Ouen A
Ouen A
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?
Antwoorden
0
0
John
John
Deze opmerking is gemaakt door de moderator op de site
hoe zorg je ervoor dat de code leeg blijft als de cel leeg is?
Antwoorden
0
0
Nick
Nick
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?
Antwoorden
0
0
crystal
crystal     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 als 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()
Ringleiding
Application.DisplayAlerts = Waar
Application.EnableEvents = Waar
Application.ScreenUpdating = True
End Sub
Antwoorden
Rapport
0
0
Pranusha
Pranusha
Deze opmerking is gemaakt door de moderator op de site
Hallo, ik wil een code om de gegevens in 6 verschillende werkmappen (in een map) met daarin opgenomen bladen naar het NIEUWE WERKBOEK te kopiëren. in vba
plz help me asp
Antwoorden
0
0
crystal
crystal     Pranusha
Deze opmerking is gemaakt door de moderator op de site
Hallo Paranusha,
Het VBA-script in het volgende artikel kan meerdere werkmappen of gespecificeerde werkbladen met werkmappen combineren tot een hoofdwerkmap. Controleer of het kan helpen.
Hoe combineer je meerdere werkmappen in één hoofdwerkmap in Excel?
Antwoorden
Rapport
0
0
Maria Soares
Maria Soares
Deze opmerking is gemaakt door de moderator op de site
Olá bom dia.
Als ik veel van de code heb, kan ik me niet voorstellen dat de relatie nauwkeurig is.
Preciso imprimir 2.400 relatório de exel que estão em pastas diferentes en não estão configuradas corretamente para impressão. Wil je me helpen met de VBA-code die je kunt automatiseren om indruk te maken? Me ajudaria muito, obrigada.
Antwoorden
0
0
crystal
crystal     Maria Soares
Deze opmerking is gemaakt door de moderator op de site
Hallo Maria Soares,
Controleer of de VBA-code in het volgende bericht kan helpen.
Hoe meerdere werkmappen in Excel afdrukken?
Antwoorden
Rapport
0
0
Andreas Shahan
Andreas Shahan
Deze opmerking is gemaakt door de moderator op de site
Mijn scenario is vergelijkbaar, behalve dat ik meerdere bladen in elk bestand heb, allemaal met verschillende namen maar consistent tussen bestanden. Is er een manier om deze code te herhalen om de gegevens in de bestanden te kopiëren en (waarden) in specifieke bladnamen in de hoofdwerkmap te plakken? De bladnamen in de master zijn dezelfde als in de bestanden. Ik wil ze doornemen. Ook zal de hoeveelheid gegevens in elk blad variëren, dus ik zal de gegevens in elk blad moeten selecteren met zoiets als dit:

Bereik ("A1"). Selecteer
Bereik(Selectie, Selectie.End(xlOmlaag)).Selecteren
Bereik(Selectie, Selectie.End(xlToRight)).Selecteren


Bestandsbladnamen zijn Giving, Services, Insurance, Car, Other Expenses, etc...

Dank bij voorbaat.
Antwoorden
0
0
crystal
crystal     Andreas Shahan
Deze opmerking is gemaakt door de moderator op de site
Hallo Andrew Shahan,
De volgende VBA-code kan uw probleem oplossen. Na het uitvoeren van de code en het selecteren van een map, komt de code automatisch overeen met het werkblad op naam en plakt de gegevens in het werkblad met dezelfde naam in de hoofdwerkmap.
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
Antwoorden
Rapport
0
0
Er zijn nog geen reacties geplaatst

Volg ons

Copyright © 2009 - www.extendoffice.com. | Alle rechten voorbehouden. Aangedreven door ExtendOffice. | Sitemap
Microsoft en het Office-logo zijn handelsmerken of gedeponeerde handelsmerken van Microsoft Corporation in de Verenigde Staten en / of andere landen.
Beschermd door Sectigo SSL