Extract unique Values by comparing Master list and copy full row to another sheet

[vijyat]

Hi,

I was wondering is someone can kindly help me out withe the particular project of mine. In the attached picture, the image on the left is "Sheet 1" and it has random data that I need to scan against the image on the right which is the approved Master List. Basically what I am trying to do is that for each cell in Column B "Sheet1" verifies against Column A in"Sheet2". For every possible match it will go on to the next cell and for every non-match(unique ID not found in Sheet 2), it will copy the entire row of Sheet1(Col A + ColB + ColC) and paste it on Sheet3 row by row for every unique entry.

I started modifying a previous code found on the forum by Hobbinton73 & SamT however I seem to be getting an error. Please help. Appreciate any input.
12361

Here is the code
VB:


Sub LookForDiscrepancies()
Dim varS1, varS2, varH1, varH2
Dim rngS1 As Range, rngS2 As Range
Dim c As Range, c1 As Range, c2 As Range
Dim iRow As Integer, iCol As Integer, i As Integer, iTest As Integer

Sheet1.Activate
Set rngS1 = Intersect(Sheet1.UsedRange, Columns("B"))
Sheet2.Activate
Set rngS2 = Intersect(Sheet2.UsedRange, Columns("A"))
Sheet3.Activate

Let iRow = iRow + 2
With rngS2
'Search for Sheet1 AU IDs on Sheet2
For Each c1 In rngS1
On Error Goto 0
Set c = .Find(what:=c1.Value) 'Look for match
If c Is Nothing Then 'Copy the AU ID to Sheet3
Sheet3.Cells(iRow, 1) = c1
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet1.UsedRange, c1.EntireRow)
Let varS2 = Intersect(Sheet2.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet1.UsedRange, c1.EntireRow).Count
Redim varH1(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH1(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH1(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 36
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With

Let iRow = iRow + 2
With rngS1
'Search for Sheet2 AU IDs on Sheet1
For Each c2 In rngS2
On Error Goto 0
Set c = .Find(what:=c2.Value) 'Look for match
If c Is Nothing Then 'Copy the AU ID to Sheet3
Sheet3.Cells(iRow, 1) = c2
Let iRow = iRow + 1
Else 'Check if rows are identical
Let varS1 = Intersect(Sheet2.UsedRange, c2.EntireRow)
Let varS2 = Intersect(Sheet1.UsedRange, c.EntireRow)
Let iCol = Intersect(Sheet2.UsedRange, c2.EntireRow).Count
Redim varH2(1 To iCol) As Integer
For i = 1 To iCol
If Not varS1(1, i) = varS2(1, i) Then
Let iTest = iTest + 1
Let varH2(i) = 1
End If
Next i
If iTest Then 'Rows are not identical
For i = 1 To iCol
Sheet3.Cells(iRow, i) = varS1(1, i)
If Not varH2(i) = 0 Then Cells(iRow, i) _
.Interior.ColorIndex = 36
Next i
Let iTest = 0
Let iRow = iRow + 1
End If
End If
Next
End With
End Sub

[Bob Phillips]

Public Sub CopyMismatches()
Dim rng As Range
Dim lastrow As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns(2).Insert
.Range("B1").Value = "tmp"
.Range("B2").Resize(lastrow - 1).Formula = "=ISNUMBER(MATCH(A2,Sheet2!A:A,0))"
Set rng = .Range("B2").Resize(lastrow - 1)
Columns(2).AutoFilter Field:=1, Criteria1:="=FALSE"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

.Rows(1).Copy Worksheets("Sheet3").Range("A1")
rng.EntireRow.Copy Worksheets("Sheet3").Range("A2")
End If
.Columns(2).Delete
Worksheets("Sheet3").Columns(2).Delete
End With

Application.ScreenUpdating = True
End Sub

[vijyat]

Oops, just realized I attached the screenshot but forgot to attach the sample excel file. Thnx XLD. Ur the best :cloud9:. I just changed the Criteria1 from "FALSE" to "TRUE" as I only wanted the Unique entries to be copied over to Sheet3. Much appreciated. I shall mark it resolved.

Umm, actually I just tried it and you were right I switched the Criteria 1 back to FALSE, however had to change the line ""=ISNUMBER(MATCH(A2,Sheet2!A:A,0))" to ""=ISNUMBER(MATCH(C2,Sheet2!A:A,0))". As per your code it was matching ColA Sheet1 with ColA Sheet2, instead I originally wanted to Match ColB Sheet 1 with ColA Sheet2.

But, you helped me with 99% of the code, so I am still thankful. :friends:

[vijyat]

I apologize for re-opening the thread. I can't seem to get my head around coding for the life of this thing. The code executes perfectly, however I am trying to modify it a little bit. How do I get it to copy on ColA, ColB & ColC instead of the "EntireRow copy" feature mentioned in the above code. I only want to copy first 3 columns to sheet 3. I tried to add another variable defining lastcol and then to go backwards using EndXlleft but i seem to be running in errors. Plz help. Thank you.

[Bob Phillips]

At least you continued this thread, not starting another :).


Public Sub CopyMismatches()
Dim rng As Range
Dim lastrow As Long
Dim numcols As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Columns("D").Insert
.Range("D1").Value = "tmp"
.Range("D2").Resize(lastrow - 1).Formula = "=ISNUMBER(MATCH(B2,Sheet2!A:A,0))"
Set rng = .Range("B2").Resize(lastrow - 1)
.Columns("D").AutoFilter Field:=1, Criteria1:="=FALSE"
On Error Resume Next
Set rng = rng.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

numcols = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range("A1:C1").Copy Worksheets("Sheet3").Range("A1")
rng.EntireRow.Copy Worksheets("Sheet3").Range("A2")
Worksheets("Sheet3").Columns("D").Resize(, numcols - 3).Delete
End If
.Columns("D").Delete
End With

Application.ScreenUpdating = True
End Sub

[vijyat]

Haha, yup,. took me a good 2 min to find how I can re-open the post link. :rotlaugh:I made another teeny weeny change to the code, instead of End(xltoLeft) as it still copied columns D(blank Column) & E(data), so I changed it to End(xltoRight) so it starts from Col A till Col C only.
thankyou.
Marked SOLVED.