VBA automatisch data kopiëren naar meerdere bestanden

[aurelius142]

Goedenavond,

Ik loop al enkele dagen te puzzelen met het volgende.

Ik heb in één folder iets meer dan 100 Excel bestanden staan met allemaal eenzelfde opmaak. In kolom A staat een uniek getal. In het ene document kunnen dit er 10 zijn, in het andere document 100.

Wat ik probeer te bereiken is dat Excel automatisch alle bestanden afgaat in de folder en alle informatie uit een basis bestand kopieert. In dit bestand staan in kolom C dezelfde codes als in de Excel bestanden. Alleen is het zo dat in dit bestand de getallen vaker voorkomen, alleen wijkt daar de informatie in kolom D t/m K af.

Ik probeer dus bij de unieke getallen in het ene document. Meerdere resultaten terug te krijgen vanuit het andere document.

Met mijn basis VBA kennis en ChatGPT ben ik een eind gekomen, alleen krijg ik hem niet compleet werkend.

Onderstaande code werkt voor één bestand. Alleen om nu 100+ de worksheet naam aan te passen is wat inefficiënt.

code:

Sub CopyDataFromSchap1()
    Dim ws41460 As Worksheet
    Dim wsSchap1 As Worksheet
    Dim lastRow41460 As Long
    Dim lastRowSchap1 As Long
    Dim codeColumn As Range
    Dim matchRange As Range
    Dim codeValue As String
    Dim copyRange As Range
    Dim destRow As Long
    
    ' Set references to worksheets
    Set ws41460 = ThisWorkbook.Sheets("Blad1") ' Change to your actual sheet name
    Set wsSchap1 = Workbooks("Schap1.xlsx").Sheets("Blad1") ' Change to your actual file and sheet names
    
    ' Find the last used rows in both sheets
    lastRow41460 = ws41460.Cells(ws41460.Rows.Count, "A").End(xlUp).Row
    lastRowSchap1 = wsSchap1.Cells(wsSchap1.Rows.Count, "C").End(xlUp).Row
    
    ' Set reference to code column in 41460 sheet
    Set codeColumn = ws41460.Range("A1:A" & lastRow41460)
    
    ' Initialize destination row
    destRow = 2
    
    ' Loop through each code in 41460 sheet
    For Each matchCell In codeColumn
        codeValue = matchCell.Value
        
        ' Find matching codes in Schap1 sheet
        Set matchRange = wsSchap1.Range("C1:C" & lastRowSchap1).SpecialCells(xlCellTypeConstants, xlTextValues)
        
        ' Loop through each match
        For Each copyRange In matchRange
            If copyRange.Value = codeValue Then
                wsSchap1.Range("C" & copyRange.Row & ":K" & copyRange.Row).Copy ws41460.Range("C" & destRow)
                destRow = destRow + 1
            End If
        Next copyRange
    Next matchCell
End Sub

Daarnaast heb ik vanuit chatGPT onderstaande code.
Deze gaat wel automatisch alle bestanden af, alleen blijf ik er tegen aan lopen dat deze slechts de eerste hit kopieert. In plaats van de meerdere waardes die er zijn.

code:

Sub ExtractDataFromSchap1()
    Dim schap1Workbook As Workbook
    Dim schap1Worksheet As Worksheet
    Dim schap1LastRow As Long
    Dim schap1Row As Variant ' Variant to handle potential errors
    Dim schap1Number As Long
    Dim mainWorkbook As Workbook
    Dim fileName As String
    
    ' Set the path to the folder containing the Excel files
    Dim folderPath As String
    folderPath = "C:\Path\To\Your\Folder\"
    
    ' Open Schap1 workbook
    Set schap1Workbook = Workbooks.Open(folderPath & "Schap1.xlsx") ' Change the file name if needed
    Set schap1Worksheet = schap1Workbook.Sheets("Sheet1") ' Change the sheet name if needed
    
    ' Get the last row with data in Schap1
    schap1LastRow = schap1Worksheet.Cells(schap1Worksheet.Rows.Count, "C").End(xlUp).Row
    
    Application.ScreenUpdating = False ' Turn off screen updating for better performance
    
    ' Loop through each Excel file in the folder
    fileName = Dir(folderPath & "*.xlsx")
    Do While fileName <> ""
        If fileName <> "Schap1.xlsx" Then ' Skip Schap1.xlsx
            ' Open the main workbook
            Set mainWorkbook = Workbooks.Open(folderPath & fileName)
            Dim mainWorksheet As Worksheet
            Set mainWorksheet = mainWorkbook.Sheets(1) ' Change the sheet index if needed
            Dim mainLastRow As Long
            mainLastRow = mainWorksheet.Cells(mainWorksheet.Rows.Count, "A").End(xlUp).Row
            
            ' Loop through each row in the main worksheet
            For mainRow = 1 To mainLastRow ' No header, start from row 1
                mainNumber = mainWorksheet.Cells(mainRow, "A").Value
                
                ' Find mainNumber in Schap1
                On Error Resume Next
                schap1Row = Application.Match(mainNumber, schap1Worksheet.Columns("C"), 0)
                On Error GoTo 0
                
                If Not IsError(schap1Row) Then
                    ' Copy data from Schap1 to the main workbook
                    schap1Worksheet.Range("C" & schap1Row & ":K" & schap1Row).Copy mainWorksheet.Cells(mainRow, "B")
                End If
            Next mainRow
            
            mainWorkbook.Close SaveChanges:=True ' Save changes and close main workbook
        End If
        
        fileName = Dir ' Move to the next file
    Loop
    
    ' Close Schap1 workbook without saving changes
    schap1Workbook.Close False
    
    Application.ScreenUpdating = True ' Restore screen updating
End Sub

Nu vroeg ik mij af of iemand mij kan verder op weg kan helpen waar ik het moet zoeken. Ik heb diverse dingen proberen samen te voegen echter heb ik het nog niet werkend gekregen.

[dixet]

Match retourneert de plek van de 1e gevonden waarde. Je zal dus nog een lusje moeten maken die na die eerste waarde verder zoekt.

Twee mogelijkheden (er zijn er vast nog meer)

• Match heeft geen mogelijkheid om een tweede of derde waarde te vinden. Je zal dus na de 1e x moeten zoeken in een reeks die begint in de rij volgend op de vorige gevonden waarde. Dus in plaats van in schap1Worksheet.Columns("C"), 0) zoeken in schap1Worksheet.Range("C" & schap1Row+1 & ":C"& lastRowSchap1 ), 0).
• Gebruik in plaats van MATCH de funtie Range.FIND. Die kan je in een lus combineren met de functie FIndNext om de volgende waarde te vinden

Aangezien je al best een eind op weg was gok ik dat je hiermee (en met ChatGPT) al weer een eind verder komt!

[aurelius142]

Hij lijkt het te doen. Heb na aanleiding van jouw feedback het e.e.a. heen en weer gestuurd richting ChatGPT en het lijkt nu te werken. Hij is nu de complete lijst aan het afwerken, als dat werkt zal ik nog voor de Tweakers onder ons even de code plaatsten ter lering en vermaak.