Hoe door werkboeken in een map te lussen en gegevens naar een masterblad in Excel te kopiëren?
Stel dat je meerdere Excel-werkboeken in een map hebt en door al deze bestanden moet lussen om gegevens uit een specifiek bereik in een consistente werkblad (bijvoorbeeld Sheet1) te kopiëren naar een masterwerkblad. Deze handleiding biedt een gedetailleerde VBA-oplossing om dit proces in Excel te stroomlijnen.
Lus door werkboeken in een map en kopieer gegevens naar een masterblad met VBA-code
Lus door bestanden in een map en kopieer gegevens naar een masterblad met VBA-code
Als u gegevens wilt kopiëren van het bereik A1:D4 in alle Sheet1-werkbladen van werkboeken in een specifieke map en ze wilt plakken in een masterblad, volg dan de volgende stappen.
1. Druk in het werkboek waarin u een masterwerkblad gaat maken op de toetsen Alt + F11 om het Microsoft Visual Basic for Applications-venster te openen.
2. Klik in het Microsoft Visual Basic for Applications-venster op Invoegen > Module. Kopieer vervolgens onderstaande VBA-code naar het codevenster.
VBA-code: lus door bestanden in een map en kopieer gegevens naar een masterblad
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 SubOpmerking:
3. Druk op de F5-toets om de code uit te voeren.
4. Selecteer in het venster Bladeren dat wordt geopend de map die de bestanden bevat waar u doorheen wilt lussen en klik vervolgens op de knop OK. Zie screenshot:
Er wordt een masterwerkblad genaamd “New Sheet” aan het einde van het huidige werkboek gemaakt. En de gegevens in het bereik A1:D4 van alle Sheet1 in de geselecteerde map worden weergegeven in het werkblad.
Gerelateerde artikelen:
Beste productiviteitstools voor Office
Verbeter je Excel-vaardigheden met Kutools voor Excel en ervaar ongeëvenaarde efficiëntie. Kutools voor Excel biedt meer dan300 geavanceerde functies om je productiviteit te verhogen en tijd te besparen. Klik hier om de functie te kiezen die je het meest nodig hebt...
Office Tab brengt een tabbladinterface naar Office en maakt je werk veel eenvoudiger
- Activeer tabbladbewerking en -lezen in Word, Excel, PowerPoint, Publisher, Access, Visio en Project.
- Open en maak meerdere documenten in nieuwe tabbladen van hetzelfde venster, in plaats van in nieuwe vensters.
- Verhoog je productiviteit met50% en bespaar dagelijks honderden muisklikken!
Alle Kutools-invoegtoepassingen. Eén installatieprogramma
Kutools for Office-suite bundelt invoegtoepassingen voor Excel, Word, Outlook & PowerPoint plus Office Tab Pro, ideaal voor teams die werken met Office-toepassingen.
- Alles-in-één suite — invoegtoepassingen voor Excel, Word, Outlook & PowerPoint + Office Tab Pro
- Eén installatieprogramma, één licentie — in enkele minuten geïnstalleerd (MSI-ready)
- Werkt beter samen — gestroomlijnde productiviteit over meerdere Office-toepassingen
- 30 dagen volledige proef — geen registratie, geen creditcard nodig
- Beste prijs — bespaar ten opzichte van losse aanschaf van invoegtoepassingen