De onderstaande procedure zoekt naar bron-werkmappen (xlsx) om deze te openen en te importeren naar de doel-werkmap.
De locatie waarin gezocht wordt is relatief ten opzichte van de locatie van de doel-werkmap.
De enige voorwaarde voor het goed functioneren van deze procedure is dat zowel de bron- als de doelwerkmap dezelfde indeling hebben qua kolommen. Voor de rest is deze functionaliteit geheel dynamisch en dus niet gebonden aan een vooraf vast gesteld aantal kolommen of rijen.
'-----------------------------------------------------------------------------------------------------------------------
' Auteur : pascalterheege.nl
' Datum : 6-1-2016
' Object : modImporteer
' Doel : xlsx-bestanden uit \bron\ importeren naar huidig werkboek
' Verwijzing : Microsft Scripting Runtime
' Bron :
'-----------------------------------------------------------------------------------------------------------------------
Option Explicit
Sub importeerBestanden()
' Variabelen declareren
Dim fso As New FileSystemObject 'FSO
Dim fld As Folder
Dim f As File
Dim strLocatie As String 'Locatie
Dim wbDoel As Workbook 'Doel
Dim rngDoel As Range
Dim wbBron As Workbook 'Bron
Dim rngBron As Range
' Variabelen initialiseren
Set wbDoel = ActiveWorkbook 'Doel
strLocatie = wbDoel.Path & Application.PathSeparator _
& "Bron" & Application.PathSeparator 'Relatieve padverwijzing t.o.v. doel.xlsm
Set fld = fso.GetFolder(strLocatie)
' Schermactiviteit uitschakelen t.b.v performance
Application.ScreenUpdating = False
' Itereren door gevonden bestanden in locatie
For Each f In fld.Files
' Alleen xlsx bestanden!
If fso.GetExtensionName(f) = "xlsx" Then
' Dynamische bron range (exclusief header)
Set wbBron = Workbooks.Open(f) 'bronbestand openen
Set rngBron = wbBron.Sheets(1).Range("A1").CurrentRegion 'bronrange is huidig bereik (currentregion) t.o.v. A1
Set rngBron = rngBron.Offset(1).Resize(rngBron.Rows.Count _
- 1, rngBron.Columns.Count) 'bronrange exlusief header!
' Dynamische doel range (laatste regel + 1)
Set rngDoel = wbDoel.Sheets(1).Range("A" & wbDoel.Sheets(1) _
.Range("A" & Rows.Count).End(xlUp).Row + 1)
' Bron kopieren naar doel
rngBron.Copy Destination:=rngDoel
' Bron sluiten
wbBron.Close
End If
Next f
' Schermactiviteit aanschakelen
Application.ScreenUpdating = True
End Sub
Download hier het oefenbestand.