Find duplicate column values across multiple workbooks, and get data row and set row data to new sheet

[itomedina25]

Hi,
I have multiple excel workbooks with data on 5 columns (A to E). The first column is the ID column. The other 4 columns are the data for that ID. Am only focus on columns A and B. Columns A and B are to be check for duplicates, specifically column B on every workbook. All workbooks are hold in the same folder. If B has data for that ID(column A) and is not equal to B in all other workbooks, then grab that row data and export to active workbook sheet1. Else if data are equal on column B export to sheet2 on active workbook. Finally, row 1, 2, and 3 are headers, those rows have to be ignored on the search.

 

[dermie_72]

what part of the code are you having difficulty with?
If you're not proficient at coding, have you tried recording your actions and going over the code.
I suggest checking out how to loop through all workbooks in a folder.

 

[itomedina25]

The code is copying every row from each workbook inside a file. I need to compare values on column B Cells with each other workbook and copy the duplicates on sheet 2 and the non duplicates for that column on sheet 3.
here is the code:
Sub tOriginal()

Dim fName As String
Dim fPath As String
Dim wb As Workbook
Dim sh As Worksheet
Dim i As Long
Dim selCell As Range
Dim dataRng As Range


Set sh = ActiveSheet

fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xlsx*")
Do
If fName <> ThisWorkbook.Name Then

Set wb = Workbooks.Open(fPath & fName)

If sh.Range("B3") = "" Then
wb.Sheets(1).Range("A3", Sheets(1).Cells(3, Columns.Count).End(xlToLeft)).Copy sh.Range("B3")
sh.Range("A2") = "Source"
End If

wb.Sheets(1).UsedRange.Offset(4).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