excel gegevens uit meerdere files extraheren naar 1 general file - vervolg

[HCLamers]

Op 2 januari is er een topic geopend om excel gegevens uit meerdere excel files te extraheren naar 1 general file. De macro die daar gegeven werd is erg handig en heb ik gebruikt voor eigen excel files. Dank voor deze macro! Echter, met deze macro kunnen gegevens uit 1 kolom gehaald worden. Is het mogelijk om de macro zo te schrijven dat er gegevens uit meerdere kolommen gehaald kunnen worden?

In bijgaande voorbeeld-exceldocumenten wil ik bijvoorbeeld de gegevens halen uit kolom G4:G17 en kolom F24:F64. Daarnaast zou ik ook graag de kopjes boven de kolommen hebben. Kan iemand me helpen hoe ik de macro kan aanpassen? Het betreft de volgende macro van Bakerman van 2 januari:

 

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

 

voorbeeld1.xlsx voorbeeld3.xlsx voorbeeld2.xlsx

[bakerman]

Plaats eens een voorbeeld van je general file hoe dit er uiteindelijk moet uit komen te zien.

[bakerman]

Aangezien een reactie uitblijft ben ik er zelf maar al aan begonnen.

Wijzig de directory waar de voorbeeldbestanden staan aan het begin van de code

Let er ook op dat de kolomkoppen exact hetzelfde zijn als de veldnamen in kolom A van de voorbeeldbestanden.

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")
    Application.ScreenUpdating = False
    sFileName = Dir(wDir & "*.xlsx")
    Sheets(1).Cells(1).CurrentRegion.Offset(1).ClearContents
    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 [Blad1$A4:G17];", rsCon, 0, 1, 1
            If Not rsData.EOF Then
                resarr = rsData.GetRows
            End If
            nRow = Sheets(1).Range("A" & rows.Count).End(xlUp).Offset(1).Row
            For x = 0 To UBound(resarr, 2)
                If resarr(0, x) <> vbNullString Then
                    Sheets(1).Cells(nRow, Application.Match(resarr(0, x), rows(1), 0)) = resarr(6, x)
                End If
            Next
            rsData.Close
            rsData.Open "SELECT * FROM [Blad1$A24:F64];", rsCon, 0, 1, 1
            If Not rsData.EOF Then
                resarr = rsData.GetRows
            End If
            For x = 0 To UBound(resarr, 2)
                If resarr(0, x) <> vbNullString And InStr(1, resarr(0, x), "Onderdeel") > 0 Then
                    Sheets(1).Cells(nRow, Application.Match(resarr(0, x), rows(1), 0)) = resarr(5, x)
                End If
            Next
             
        End If
        sFileName = Dir: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing
    Loop
    Application.ScreenUpdating = True
End Sub

 

ADOB_test.xlsm

14 oktober 2019 aangepast door bakerman

[HCLamers]

Bedankt voor je reactie en excuses voor mijn late reactie.

Bijgaand een voorbeeld van hoe het eruit moet komen te zien. Inderdaad zoals in jouw voorbeeld.

Ik ga je nieuwe macro toepassen.

 

Alvast dank!! Als ik nog vragen heb dan hoor je van me.

Overzicht.xlsm

[HCLamers]

Hallo bakerman,

 

De nieuwe macro werkt perfect! Hartstikke bedankt voor je hulp!

[kweezie wabbit]

Is het probleem opgelost en heb je verder geen vragen meer, geef dan een seintje zodat we het onderwerp kunnen afsluiten.

[HCLamers]

Hallo,

 

De macro werkt en ik heb op dit moment geen vragen meer.

Bedankt voor alle hulp!

[kweezie wabbit]

OK, dan sluiten we het topic af.

Succes nog.