Compare three work sheets problem

[malarvel]

I'm trying to compare three sheets in excel and have matching column data copy the entire row into a new fourth sheet.

Example:
Compare Sheet 1 column A (empid) with Sheet 2 column A(empid) and sheet3 column A(empid) if the record match, copy the entire row of matching sheet 2 & Sheet 3 column data to a Sheet 4.
I have written code but the doesn't work






Dim lRow, lrow2, Lrow3 As Long
Dim fValue As Range


Sheets("Sheet1").Select
lRow = Range("A10").End(xlDown).Row
lrow2 = Sheets("Sheet2").Range("A5").End(xlDown).Row
Lrow3 = Sheets("Sheet3").Range("A5").End(xlDown).Row


For Each cell In Range("A10:A" & lRow)


With Sheets("Sheet2").Range("A5:A" & lrow2)
Set fValue = .Find(cell.Value, LookIn:=xlValues)
If fValue Is Nothing Then
cell.EntireRow.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
End With




With Sheets("Sheet3").Range("A5:A" & Lrow3)
Set fValue = .Find(cell.Value, LookIn:=xlValues)
If fValue Is Nothing Then
cell.EntireRow.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
End With


Next cell


I have attached sample data for reference.

Any help would be appreciated

[SamT]

if the record match, copy the entire row of matching sheet 2That code is copying them if they don't match.
If fValue Is Nothing

And it is copying only sheet 1 Rows.

For Each cell In Range("A10:A" & lRow)
'Blah, Blah
cell.EntireRow.Copy

It would be really crude and slow to Copy the rows from alternating sheets, so just Sort Sheet 4 after this code Runs


Sub VBAX_SamT()
Dim ID1 As Range
Dim ID2 As Range
Dim ID3 As Range
Dim ID4 As Range
Dim Cel As Range
Dim Found1 As Range
Dim Found2 As Range

Set ID1 = Sheets("Sheet1").Range("A:A")
Set ID2 = Sheets("Sheet2").Range(Range("A1"), Range("A1").End(xldown))
Set ID3 = Sheets("Sheet3").Range(Range("A1"), Range("A1").End(xldown))
Set ID4 = Sheets("Sheet4").Range("A1")

For Each Cel In ID2
Set Found1 = ID1.Find(Cel.Value)
If Found1 Is Nothing Then
Cel.EntireRow.Copy ID4
Set ID4 = ID4.Offset(1)
End If
Next Cel

Set ID4 = ID4.Offset(1) 'Empty Row

For Each Cel In ID2
Set Found1 = ID1.Find(Cel.Value)
Set Found2 = ID2.Find(Cel.Value)
If Found1 Is Nothing And Found2 is Nothing Then
Cel.EntireRow.Copy ID4
Set ID4 = ID4.Offset(1)
End If
Next Cel

End Sub

Note that the code does not copy from sheet 3 if the ID is found on sheet1 or on sheet2. There will be a blank Row on sheet4 between sheet2 IDs and sheet3 IDs