excel gegevens uit meerdere files extraheren naar 1 general file

[janlazeure]

Beste,

 

Ik heb een map met een paar honderd excel dokumenten staan. Al deze excels hebben een eerste tabblad "Personalia"  met persoonsgegevens zoals naam, voornaam, emailadres, ...

Nu wil ik in plaats van alle excels apart te moeten openen op een automatische manier telkens een aantal cellen automatisch laten kopieren naar een andere excel file vb genoemd database. telkens in een nieuwe kolom zodat ik er nadien een filter kan opzetten.

Ik wil daarbij vb alle cellen A1, A2, A3, A4, .....

Dat zal waarschijnlijk met VBA moeten gebeuren vermoed ik. Evenwel ken ik dit niet zo goed. Kan er mij iemand helpen ?

In bijlage voeg ik een aantal voorbeeldbestanden bij en een algemeen database bestand.

Alvast heel erg bedankt en beste wensen

mvg

jan

Database.xlsx

File bert.xlsx

File jan.xlsx

File pol.xlsx

[bakerman]

Je databasebestand is leeg dus waar moeten de gegevens dan komen ?

[janlazeure]

Gewoon op het eerste tabblad in kolommen

Wat wel nodig is is dat als ik het database bestand nadien terug sluit en terug heropen deze gegevens zijn bewaard blijven staan en als ik er bijvoeg dan steeds aansluiten waar de vorige zijn geëindigd

2 januari 2019 aangepast door janlazeure

[bakerman]

Wijzig de Const wDir in de correcte map waar alle bestanden staan.

Sub ConsolidateAll()
    Dim rsCon As Object, rsData As Object, sFileName As String
    Dim Prov As String, ExProp As String, resarr ', wDir As String
    Const wDir = "D:\Test2\"
    Prov = IIf(Val(Application.Version) < 12, "Microsoft.Jet.OLEDB.4.0", "Microsoft.ACE.OLEDB.12.0")
    ExProp = IIf(Val(Application.Version) < 12, "8.0", "12.0")
    Sheets(1).Cells(1).CurrentRegion.Offset(1).ClearContents
    sFileName = Dir(wDir & "*.xlsx")
    Do While sFileName <> ""
        If sFileName <> ThisWorkbook.Name Then
            Set rsCon = CreateObject("ADODB.Connection"): Set rsData = CreateObject("ADODB.Recordset")
            rsCon.Open "Provider=" & Prov & ";Data Source=" & wDir & sFileName & _
                            ";Extended Properties=""Excel " & ExProp & ";HDR=No"";"
            rsData.Open "SELECT * FROM [Personalia$B2:B14];", rsCon, 0, 1, 1
            If Not rsData.EOF Then
                resarr = rsData.GetRows
            End If
            Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(resarr, 1) + 1, UBound(resarr, 2) + 1) = resarr
            sFileName = Dir: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing
        End If
    Loop
End Sub

 

janlazeure.xlsm

[janlazeure]

dag Bakerman,

 

heem erg bedankt voor de VBA code. Gezien ik van VBA niets ken, begrijp ik niet goed wat je bedoelt met wijzig de const wdir?

Wat dien ik juist ' in niet kennerstaal' te doen?

alvast bedankt

jan

[emielDS]

 

verander

"D:\Test2\"

in naam van de map waar de bestanden in staan bv  "C: \werk"

 

2 januari 2019 aangepast door emielDS

[kweezie wabbit]

Probleem opgelost.

Topic gesloten.