Ga naar inhoud

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


HCLamers
 Delen

Aanbevolen berichten

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

Link naar reactie
Delen op andere sites

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

aangepast door bakerman
Link naar reactie
Delen op andere sites

  • 2 weken later...
Gast
Dit topic is nu gesloten voor nieuwe reacties.
 Delen

×
×
  • Nieuwe aanmaken...

Belangrijke informatie

We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.