Script to find duplicates in 2 separate sheets and if the entire row is the same copy to 3rd sheet

[rickadams]

I have 2 spreadsheets. I need a way to compare the entire row from sheet 1 and if that row matches any row in sheet 2 then copy all of that information to a 3rd sheet. Or if it is easier to just highlight the entire row in the 2nd sheet because it is a duplicate from the first sheet.

Sheet 1 format
[TABLE="width: 1116"]
<tbody>[TR]
[TD]Unit - Address[/TD]
[TD]Unit City / State / Zip[/TD]
[TD]First Name[/TD]
[TD]Last Name[/TD]
[TD]Email[/TD]
[TD]Phone Number[/TD]
[/TR]
[TR]
[TD]1 West St 2nd Fl[/TD]
[TD]Anytown, AZ 77815[/TD]
[TD]Shames[/TD]
[TD]Smith[/TD]
[TD]shamesS1@mail.com[/TD]
[TD](110) 555-1212[/TD]
[/TR]
[TR]
[TD]1 West St 2nd Fl[/TD]
[TD]Everytown, NJ 08151[/TD]
[TD]David[/TD]
[TD]Doe[/TD]
[TD]dleib7777@nomail.com[/TD]
[TD](555) 555-5692[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 1116"]
<tbody>[TR]
[TD]11 E 12Th St [/TD]
[TD]Everytown, NJ 08151[/TD]
[TD]Jane [/TD]
[TD]Smith[/TD]
[TD]no email [/TD]
[TD](555) 555-6200[/TD]
[/TR]
</tbody>[/TABLE]


Sheet 2 format
[TABLE="width: 1116"]
<tbody>[TR]
[TD]Unit - Address[/TD]
[TD]Unit City / State / Zip[/TD]
[TD]First Name[/TD]
[TD]Last Name[/TD]
[TD]Email[/TD]
[TD]Phone Number[/TD]
[/TR]
[TR]
[TD]1 West St 2nd Fl[/TD]
[TD]Anytown, AZ 77815[/TD]
[TD]Shames[/TD]
[TD]Smith[/TD]
[TD]shamesS1@mail.com[/TD]
[TD](110) 555-1212[/TD]
[/TR]
[TR]
[TD]1 West St 2nd Fl[/TD]
[TD]Everytown, NJ 08151[/TD]
[TD]David[/TD]
[TD]Doe[/TD]
[TD]dleib7777@nomail.com[/TD]
[TD](555) 555-5692
[/TD]
[/TR]
</tbody>[/TABLE]

So the examples above the first 2 names would copy over to new sheet (or highlight them in the 2nd sheet) however the 3rd name (Jane Smith) would not copy or highlight because that person is new.

Thank you all in advance!

 

[ttray33y]

say your sheet1 and sheet2 headers is from A1 to F1 and all data starts in row 2, try this.

Private Sub fndSymX()


Dim lsheet1 As Worksheet
Dim lsheet2 As Worksheet


Dim lrow1 As Long
Dim lrow2 As Long


Set lsheet1 = ActiveWorkbook.Sheets("Sheet1")
Set lsheet2 = ActiveWorkbook.Sheets("Sheet2")


lrow1 = lsheet1.Cells(Rows.Count, 1).End(xlUp).Row
lrow2 = lsheet2.Cells(Rows.Count, 1).End(xlUp).Row


Dim x As Long
Dim y As Long


Application.ScreenUpdating = False


For x = 2 To lrow1
    For y = 2 To lrow2
        If lsheet1.Cells(x, 1) = lsheet2.Cells(y, 1) And lsheet1.Cells(x, 2) = lsheet2.Cells(y, 2) And lsheet1.Cells(x, 3) = lsheet2.Cells(y, 3) And lsheet1.Cells(x, 4) = lsheet2.Cells(y, 4) And lsheet1.Cells(x, 5) = lsheet2.Cells(y, 5) And lsheet1.Cells(x, 6) = lsheet2.Cells(y, 6) Then
            With lsheet2
                .Range(.Cells(y, 1), .Cells(y, 6)).Interior.ColorIndex = 4
            End With
        End If
    Next y
Next x
Application.ScreenUpdating = True


End Sub

SME -Edd

 

[Fluff]

Another option

Sub CopyDupes()

   Dim Cl As Range
   Dim ValU As String
   Dim Dic As Object
   
   Set Dic = CreateObject("scripting.dictionary")
   With Sheets("Sheet4")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         ValU = Join(Application.Index(Cl.Resize(, 6).Value, 1, 0), ",")
         If Not Dic.exists(ValU) Then Dic.Add ValU, Nothing
      Next Cl
   End With
   With Sheets("Sheet5")
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         ValU = Join(Application.Index(Cl.Resize(1, 6).Value, 1, 0), ",")
         If Dic.exists(ValU) Then Cl.Resize(, 6).Interior.Color = 45678
      Next Cl
   End With