CODEWITHSUNDEEP
excelvba
matr3p
matr3p

Reputation: 73

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

I have multiple Excel workbooks 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.

The following doesn't work for workbooks with multiple sheets and is 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 removes the first five rows and 8th row with the header being row 7.

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

Upvotes: 0

Views: 395

Answers (2)

ASH
ASH

Reputation: 20322

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.

enter image description here

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.

Upvotes: 1

pgSystemTester
pgSystemTester

Reputation: 9932

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

Upvotes: 1

Related Questions