VBA Copy data from 1 Excel file to multiple Excel Files.

[aurelius142]

Short version: I am trying to change the code below, so worksheet 41460 can be any Excel file in a certain folder:

Further explanation:
I have more than 100 Excel files in a single folder, all with the same format. Column A contains a unique number. In one document, there might be 10 of these unique numbers, while in another document, there could be 100.

What I'm trying to achieve is to have Excel automatically go through all the files in the folder and copy all the information from the base file. In this base file, the same codes are present in column C as in the Excel files. However, in this base file, the numbers appears multiple times, but the information in columns D to K differs.

So, what I'm attempting is to get multiple results from the other file for the unique numbers present in one document.

With my basic VBA knowledge and ChatGPT's help, I've made some progress, but I haven't been able to make it fully functional.
The code provided below works for a single file. However, updating the worksheet name for more than 100 files is somewhat inefficient.

The code below is based on one workbook named 41460. However, this workbook name can be anything.

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

Hopefully anyone can help me/guide me how to fix it. I couldn't make it work with ChatGPT.