Find duplicate column values across multiple workbooks, and extract columns row data to new sheet-CodePudding

I have multiple Excel workbooks with some having multiple worksheets.

I'm trying to export the duplicates across the workbooks into a new workbook using Column A of each workbook as the unique value. All the workbooks are in the same directory.

I have come up with the following but it seems that it doesn't work for workbooks with multiple sheets and is also not accurate for some workbooks.

Sub CheckDuplicateAcrossWorkbook()
    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
                sh.Range("A1") = "Source"
            End If
            wb.Sheets(1).UsedRange.Offset(1).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 = ""
End Sub
```

The original code which removes the first five rows and 8th row with the header being row 7.

```vba
Sub CheckDuplicateAcrossWorkbookOriginal()
    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

CodePudding user response：

You need to loop through each sheet of the opened file, rather than just using the first one. Try this... note the addtion of eSheet.

Sub CheckDuplicateAcrossWorkbook()
Dim fName As String, fPath As String, wb As Workbook 
Dim sh As Worksheet, i As Long, eSheet As Worksheet
Set sh = ActiveSheet


fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xls*")
        Do
            If fName <> ThisWorkbook.Name Then
                Set wb = Workbooks.Open(fPath & fName)
                
                    For Each eSheet In wb.Worksheets
                        If sh.Range("B1") = "" Then
                            sh.Range("A1") = "Source"
                        End If
                        eSheet.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
                Next eSheet
                wb.Close
            End If
            Set wb = Nothing
            fName = Dir
        Loop Until fName = ""
End Sub

CodePudding user response：

I feel like some people here won't like this solution, because it's not a coding solution, but this will work for you Kaiju.

https://www.rondebruin.nl/win/addins/rdbmerge.htm

I don't know what kind of 'duplicate' you are trying to find, but when everything is merged together, you can do whatever you need to do. The merge process is pretty intuitive. Just follow the steps in the landing page, and you should get what you want.