VBA Macro - Find duplicate column values across multiple workbooks, and extract/collate row data to new sheet

[RiskControlsAnalyst]

Hi,


First of all, thanks for taking the time to look at my post!





I have multiple excel workbooks(all with just the one sheet) which is the daily output from another system. Multipleworkbooks sometimes have the same value in column A (essentially an ID number)but different values in the following columns of that row.


I'm looking to use a separateworkbook with a macro/query which finds duplicates in column A of all of theworkbooks within a given folder. All duplicates found, accompanied with all thedata in that row, will then be collated into a workbook.


The first 5 rows of each ofthe reports needs to be excluded from the duplicate-output (title/date ofreport, blank rows), with the headers being row7 (same headers on every output).However, row8 also needs to be excluded (cumulative totals of each column).





Example of data:


Workbook1-(Monday’s DataOutput)





---- A ---- B ---- C ---- D


1 [Report Title]


2


3 [Date]


…


6 ------ ID --------- Colour---- Oth1 ---- Oth2


7 ------ N/A ------- N/A --------3 -------- 2


8 ------ 10001 ---- Blue -------1 -------- 0


9 ------ 10002 ---- Brown -----1 ------- 0


10 ---- 10003 ---- Blue ------- 0 ------- 0


11 ---- 10004 ---- Green -----0 ------- 1


12 ---- 10005 ---- Green -----1 ------- 1








Workbook2-(Tuesday’s DataOutput)





---- A ---- B ---- C ---- D


1 [Report Title]


2


3 [Date]


…


6 ------ ID -------- Colour---- Oth1 ---- Oth2


7 ------ N/A ------- N/A --------3 ------- 2


8 ------ 20001 ---- Blue ------1 -------- 0


9 ------ 20002 ---- Brown ----1 ------- 0


10 ---- 20004 ---- Green ---- 0------- 1


11 ---- 10003 ---- Blue ------ 0 ------- 1


12 ---- 20005 ---- Green ---- 1------- 1











Workbook-Duplicates





------- A ---- B ---- C ---- D


1 ---- ID --------- Colour---- Oth1 ---- Oth2


2 ---- 10003 ---- Blue ------ 0 -------- 0


3 ---- 10003 ---- Blue ------ 0 -------- 1

 

[JLGWhiz]

This assumes that your workbook hosting the code will be in the same directory as the files you are testing, and that the files you are testing are the only other Excel files in that folder.

Sub t()
Dim fName As String, fPath As String, wb As Workbook, sh As Worksheet, i As Long
Set sh = ActiveSheet
fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xls*")
        Do
            If fName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(fPath & fName)
                If sh.Range("B1") = "" Then
                    wb.Sheets(1).Range("A7", Sheets(1).Cells(7, Columns.Count).End(xlToLeft)).Copy sh.Range("B1")
                    sh.Range("A1") = "Source"
                End If
                wb.Sheets(1).UsedRange.Offset(8).Copy sh.Cells(Rows.Count, 2).End(xlUp)(2)
                With sh
                    .Range(.Cells(Rows.Count, 1).End(xlUp)(2), .Cells(Rows.Count, 2).End(xlUp).Offset(, -1)) = fName
                End With
                wb.Close
            End If
            Set wb = Nothing
            fName = Dir
        Loop Until fName = ""    
    For i = sh.UsedRange.Rows.Count To 2 Step -1
        If Application.CountIf(sh.Range("B:B"), sh.Cells(i, 2).Value) = 1 Then Rows(i).Delete
    Next
End Sub

 

[RiskControlsAnalyst]

That is amazing, it completely works as expected! Thank you so much!

 

[JLGWhiz]

That is amazing, it completely works as expected! Thank you so much!

You are welcome,
regards, JLG