In dit artikel gaan we een macro maken om gegevens van meerdere werkmappen in een map naar een nieuwe werkmap te kopiëren.
We zullen twee macro's maken; één macro kopieert alleen records van de eerste kolom naar de nieuwe werkmap en de tweede macro kopieert alle gegevens erin.
Ruwe data voor dit voorbeeld bestaan uit aanwezigheidsregistraties van medewerkers. In de TestFolder hebben we meerdere Excel-bestanden. Bestandsnamen van Excel-bestanden vertegenwoordigen een bepaalde datum in het formaat "ddmmjjjj".
Elk Excel-bestand bevat de datum, werknemer-ID en werknemersnaam van de werknemers die op die specifieke dag aanwezig waren.
We hebben twee macro's gemaakt; "CopyingSingleColumnData" en "CopyingMultipleColumnData". De macro "CopyingSingleColumnData" kopieert alleen records uit de eerste kolom van alle bestanden in de map naar de nieuwe werkmap. De macro "CopyingMultipleColumnData" kopieert alle gegevens van alle bestanden in de map naar de nieuwe werkmap.
De macro "CopyingSingleColumnData" kan worden uitgevoerd door op de knop "Copying Single Column" te klikken. De macro "CopyingMultipleColumnData" kan worden uitgevoerd door op de knop "Meerdere kolommen kopiëren" te klikken.
Voordat u de macro uitvoert, moet u het pad van de map opgeven in het tekstvak, waar Excel-bestanden worden geplaatst.
Wanneer op de knop "Kopieer enkele kolom" wordt geklikt, wordt een nieuwe werkmap "ConsolidatedFile" gegenereerd in de gedefinieerde map. Deze werkmap bevat geconsolideerde gegevens uit de eerste kolom van alle bestanden in de map.
De nieuwe werkmap bevat alleen records in de eerste kolom. Zodra we de geconsolideerde gegevens hebben, kunnen we het aantal aanwezige werknemers op een bepaalde dag achterhalen door het aantal datums te tellen. Telling van een bepaalde datum is gelijk aan het aantal werknemers dat op die bepaalde dag aanwezig is.
Wanneer op de knop "Meerdere kolommen kopiëren" wordt geklikt, wordt de nieuwe werkmap "ConsolidatedAllColumns" in de gedefinieerde map gegenereerd. Deze werkmap bevat geconsolideerde gegevens van alle records van alle bestanden in de map.
De nieuwe werkmap die is gemaakt, bevat alle records van alle bestanden in de map. Zodra we de geconsolideerde gegevens hebben, hebben we alle aanwezigheidsgegevens beschikbaar in één bestand. We kunnen gemakkelijk het aantal medewerkers vinden dat op die bepaalde dag aanwezig was en ook de namen krijgen van de medewerkers die op die bepaalde dag aanwezig waren.
Code uitleg
Blad1.TextBox1.Waarde
Bovenstaande code wordt gebruikt om de waarde in het tekstvak "TextBox1" van het blad "Blad1" te krijgen.
Dir(Mappad & "*.xlsx")
Bovenstaande code wordt gebruikt om de naam van het bestand te krijgen, dat de bestandsextensie ".xlsx" heeft. We hebben een jokerteken * gebruikt voor een bestandsnaam met meerdere tekens.
Terwijl bestandsnaam ""
Telling1 = Telling1 + 1
ReDim Preserve FileArray (1 te tellen1)
FileArray(Count1) = Bestandsnaam
Bestandsnaam = Dir()
Wend
Bovenstaande code wordt gebruikt om bestandsnamen van alle bestanden in de map te krijgen.
Voor i = 1 Naar UBound (FileArray)
Volgende
Bovenstaande code wordt gebruikt om door alle bestanden in de map te bladeren.
Bereik ("A1", Cellen(LastRow, 1)).Kopieer DestWB.ActiveSheet.Cells(LastDesRow, 1)
Bovenstaande code wordt gebruikt om het record van de eerste kolom naar de doelwerkmap te kopiëren.
Bereik ("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Kopieer DestWB.ActiveSheet.Cells(LastDesRow, 1)
Bovenstaande code wordt gebruikt om alle records van de actieve werkmap naar de doelwerkmap te kopiëren.
Volg hieronder voor de code:
Optie Expliciete Sub CopyingSingleColumnData() 'variabelen declareren Dim FileName, FolderPath, FileArray(), FileName1 As String Dim LastRow, LastDesRow, Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1.TextBox1 Backslash invoegen in het mappad als backslash(\) ontbreekt If Right(FolderPath, 1) "\" Then FolderPath = FolderPath & "\" End If 'Zoeken naar Excel-bestanden FileName = Dir(FolderPath & "*.xlsx") Count1 = 0 'Door alle Excel-bestanden in de map bladeren While FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray(1 To Count1) FileArray(Count1) = FileName FileName = Dir() Wend 'Een nieuwe werkmap maken Set DestWB = Workbooks.Add For i = 1 To UBound(FileArray) 'Finding the last row in the workbook LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row 'Openen van de Excel-werkmap Set SourceWB = Workbooks.Open (FolderPath & FileArray(i)) LastRow = ActiveCell.SpecialCells(xlCellTypeLas tCell).Row 'De gekopieerde gegevens naar de laatste rij in de doelwerkmap plakken If LastDesRow = 1 Then 'De eerste kolom naar de laatste rij in de doelwerkmap kopiëren Range("A1", Cells(LastRow, 1)).Copy DestWB. ActiveSheet.Cells(LastDesRow, 1) Else Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1) End If SourceWB.Close False Volgende 'Opslaan en sluiten van een nieuwe Excel werkmap DestWB.SaveAs FileName:=FolderPath & "ConsolidatedFile.xlsx" DestWB.Close Set DestWB = Nothing Set SourceWB = Nothing End Sub Sub CopyingMultipleColumnData() 'Declaring variabelen Dim FileName, FolderPath, FileArray(), FileName1 As String Dim LastRow, LastDesRow , Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1.TextBox1.Value 'Backslash invoegen in het mappad als backslash (\) ontbreekt If Right (FolderPath, 1) "\" Then FolderPath = FolderPath & "\" End If 'Zoeken naar Excel-bestanden FileName = Dir(FolderPath & "*.xlsx") Count1 = 0 'Doorloop alle Excel-bestanden in de map While FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray(1 To Count1) FileArray(Count1) = FileName FileName = Dir() Wend 'Een nieuwe werkmap maken Set DestWB = Workbooks.Add For i = 1 To UBound(FileArray) 'De laatste rij in de werkmap zoeken LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row 'De Excel-werkmap openen Set SourceWB = Workbooks.Open(FolderPath & FileArray(i)) 'De gekopieerde gegevens naar de laatste rij in de doelwerkmap plakken If LastDesRow = 1 Then 'Alle gegevens in het werkblad kopiëren naar de laatste rij in de doelwerkmap Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)). Kopieer DestWB.ActiveSheet.Cells(LastDesRow, 1) Else Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1) End If SourceWB.Close False Volgende 'Opslaan en sluiten een nieuwe Excel-werkmap DestWB.SaveAs FileName:=FolderPath & "ConsolidatedAllColumns.xlsx" DestWB.Close Set D estWB = Niets Instellen BronWB = Niets Einde Sub
Als je deze blog leuk vond, deel hem dan met je vrienden op Facebook. Ook kunt u ons volgen op Twitter en Facebook.
We horen graag van u, laat ons weten hoe we ons werk kunnen verbeteren en voor u kunnen verbeteren. Schrijf ons op de e-mailsite
