Dit is de zesde blogpost uit de reeks die dieper ingaat op een aantal technieken die datatransformatie in Excel VBA kunnen versnellen.
- Kopiëren van cellen met VBA
- Gegevens toevoegen aan een tabel
- Een bestand openen en data overbrengen naar het doelbestand
- Een reeks bestanden openen en data overbrengen naar het doelbestand
- Gegevens opslaan in een recordset
- Gegevens uit meerdere bestanden met een recordset uitlezen zonder de bestanden te openen
- Een recordset maken, gebaseerd op data uit 2 verschillende worksheets
In de vorige blogpost hebben we gezien hoe data in een recordset opgeslagen kan worden. In deze blog gaan we die techniek gebruiken om alle bestanden in een folder te openen en hun data naar het doelbestand over te brengen. De kennis die nodig is om een bestand te openen kan je in de vorige blogs uit deze reeks terugvinden.
Ook in deze blog zullen we de klassieke methode (workbooks.open) met de recordset methode vergelijken.
Voor dit voorbeeld gebruik ik 20 identieke bestanden die elk 10 kolommen en 5000 rijen data bevatten. Het resultaat wordt zodoende een werkblad met 100K rijen en 10 kolommen. Alle bestanden staan in dezelfde folder.
Opmerking: We gaan voor deze oplossing met een klassieke lijst werken en niet met een tabel. Zie blog 2 in deze reeks in verband met data naar een tabel kopiëren.
Eerst bereid je de code voor om alle bestanden uit een folder te overlopen. De bestanden worden hierbij nog niet geopend, enkel hun naam wordt in onze variabele gestopt. De naam van elk bestand geef je weer in het ‘venster direct’ (Debug Window) of je kiest voor een ‘messagebox’. Als de lus werkt, voer je de dataoverdracht toe aan de code.
Sub GetDataFromFiles()
Dim fldr As FileDialog
Dim strPath As String
Dim myFolder As String
Dim myFile As String
strPath = “C:\Xylos\BLOG\” ‘ Dialog will start from this folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) ‘ Select Folder, do not open folder
With fldr
.Title = “Select a Folder”
.AllowMultiSelect = False ‘ Select only 1 folder
.InitialFileName = strPath ‘ Folder location
If .Show <> -1 Then Exit Sub ‘ Quit when user cancels
myFolder = .SelectedItems(1)
End With
myFile = Dir(myFolder & “\*.xlsb”)
Do While myFile <> “”
Debug.Print myFile
myFile = Dir() ‘ Get Next File
Loop
End Sub
Hou er rekening mee dat het dialoogvenster dient om een folder aan te wijzen. Je mag niet dubbelklikken om de inhoud van de folder te tonen. Duid de juiste folder aan en bevestig met ‘OK’.
Tip: Met bovenstaand voorbeeld wordt de naam van elke aanwezige file in de folder in het ‘Venster Direct’ (Immediate Window) getoond door de opdracht ‘Debug.print’. Als het venster niet open staat kan je het zichtbaar maken met de sneltoets ‘CTRL+G’.
Nu kan je de code toevoegen die elke file beurtelings opent, de data kopieert en naar het doelbestand overbrengt.
Je start hierbij best met de klassieke methode waarbij een bestand geopend, gelezen en gesloten wordt via het ‘workbook’ object.
De aangepaste code:
Sub GetDataFromFiles()
Dim fldr As FileDialog
Dim strPath As String
Dim myFolder As String
Dim myFile As String
Dim wbMain As Workbook
Dim wsMain As Worksheet
Dim wbData As Workbook
Dim wsData As Worksheet
Dim lngPasteRow As Long
strPath = “C:\Xylos\BLOG\” ‘ Dialog will start from this folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) ‘ Select Folder, do not open folder
With fldr
.Title = “Select a Folder”
.AllowMultiSelect = False ‘ Select only 1 folder
.InitialFileName = strPath ‘ Folder location
If .Show <> -1 Then Exit Sub ‘ Quit when user cancels
myFolder = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Debug.Print Now
myFile = Dir(myFolder & “\*.xlsb”)
Set wbMain = ActiveWorkbook
Set wsMain = ActiveSheet
lngPasteRow = 2
Do While myFile <> “”
Set wbData = Workbooks.Open(myFolder & “\” & myFile)
Set wsData = wbData.Sheets(1)
wsData.Cells(1, 1).CurrentRegion.Copy wsMain.Cells(lngPasteRow, 1)
Set wsData = Nothing
wbData.Close False
lngPasteRow = wsMain.Cells(1, 1).End(xlDown).Row
myFile = Dir() ‘ Get Next File
Loop
Application.ScreenUpdating = True
Debug.Print Now
End Sub
Deze code wordt in ongeveer 8 seconden uitgevoerd. Zonder gebruik te maken van ‘screenupdating’ duurt het langer en zie je elk bestand afzonderlijk geopend worden, wat een knipperend scherm als gevolg heeft.
In het volgende voorbeeld gaan we opnieuw gebruik maken van recordsets zoals we in de vorige blog uit deze reeks geleerd hebben.
Sub GetDataFromFiles()
Dim fldr As FileDialog
Dim strPath As String
Dim myFolder As String
Dim myFile As String
Dim wbMain As Workbook
Dim wsMain As Worksheet
Dim wbData As Workbook
Dim wsData As Worksheet
Dim lngPasteRow As Long
‘ New variables
Dim myConnection As String
Dim RS As ADODB.Recordset
Dim mySQL As String
Application.ScreenUpdating = False
strPath = “C:\Xylos\BLOG\” ‘ Dialog will start from this folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker) ‘ Select Folder, do not open folder
With fldr
.Title = “Select a Folder”
.AllowMultiSelect = False ‘ Select only 1 folder
.InitialFileName = strPath ‘ Folder location
If .Show <> -1 Then Exit Sub ‘ Quit when user cancels
myFolder = .SelectedItems(1)
End With
Application.ScreenUpdating = False
Debug.Print Now
myFile = Dir(myFolder & “\*.xlsb”)
Set wbMain = ActiveWorkbook
Set wsMain = ActiveSheet
lngPasteRow = 2
Do While myFile <> “”
myConnection = “Provider=Microsoft.ACE.OLEDB.12.0;” & _
“Data Source=” & myFolder & “\” & myFile & “;Extended Properties=Excel 12.0”
mySQL = “SELECT * FROM [Sheet1$]”
Set RS = New ADODB.Recordset
RS.Open mySQL, myConnection, adOpenForwardOnly, adLockOptimistic
wsMain.Cells(lngPasteRow, 1).CopyFromRecordset RS
RS.Close
Set RS = Nothing
lngPasteRow = wsMain.Cells(1, 1).End(xlDown).Row
myFile = Dir() ‘ Get Next File
Loop
Application.ScreenUpdating = True
Debug.Print Now
End Sub
De uitvoertijd van deze code is nu tot 4 seconden verminderd. De methode levert dus een zeer interessante snelheidswinst op bij het uitlezen van een hele reeks bestanden.
Volgende blogpost: Een recordset maken, gebaseerd op data uit 2 verschillende worksheets (7/7).
Heb je na het lezen van deze blogpost de Excel- of zelfs de Power BI-microbe te pakken? Bekijk dan zeker ons aanbod open Excel-opleidingen en wie weet zien we je binnenkort in Antwerpen of Brussel.
