Comparing 2 Lists And Extracting Unique Results

[muchobrento]

Hi all

On a pretty regular basis I run into this problem, so I finally thought I'd see if the community can help me solve it.

I'd like to take 2 separate lists and be able to extract a 3rd list of all entries not present in both lists. For example:

• List A has 2,500 entries
• List B has 2,700 entries (but I have no idea which entries are unique to List B)
• List C (the result of our operation) has 200 extracted entries that are not present in both lists

As a side note, I have no idea how to write VBA script, or how to even use it. But, if the solution requires me to use a VBA script, I'll do my best to learn what I need to. But, please try to keep the instructions at their most basic level, since I'm a noob.

Thanks so much in advance!

MuchoBrento

 

[Trebor76]

Hi MuchoBrento,

This macro will do the job:

Option Explicit
Sub Macro1()
   
    Dim rngCell As Range
    Dim rngRange1 As Range
    Dim rngRange2 As Range
    
    Set rngRange1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) 'Sets the first list from Row 2 in Col. A to the last Row in Col. A. Change to suit.
    Set rngRange2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row) 'Sets the second list from Row 2 in Col. B to the last Row in Col. B. Change to suit.
    
    Application.ScreenUpdating = False 'Turn screen updating off
    
    For Each rngCell In rngRange1 'Loop through first range putting each no match to the second range to Col. C. Change to suit.
        If Evaluate("COUNTIF(" & rngRange2.Address & "," & rngCell.Address & ")") = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = rngCell.Value
        End If
    Next rngCell
    
    For Each rngCell In rngRange2 'Loop through second range putting each no match to the first range to Col. C. Change to suit.
        If Evaluate("COUNTIF(" & rngRange1.Address & "," & rngCell.Address & ")") = 0 Then
            Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = rngCell.Value
        End If
    Next rngCell
    
    Set rngCell = Nothing
    Set rngRange1 = Nothing
    Set rngRange2 = Nothing
    
    Application.ScreenUpdating = True 'Turn screen updating back on
    
End Sub

I've made notes along the way to try and explain what's happening. Post back re how it goes.

Regards,

Robert

 

[muchobrento]

Robert-

Thanks so much for the reply! I tried to run the macro, but ran into a problem. In my test, I had 860 entries in Column A, and I had 1,050 entries in Column B. After running the macro (which I'm not really even sure if I did it correctly), in Column C it ended up with 1,704 entries. If it works the way that I imagined it, even if every item in Column B were unique, then Column C should have at most the same number of entries as Column B. Does that make sense?

Oh, and after running the test, I realized that that there is adjacent data related to Column B that needs to "stay" with the data when it is added to Column C. For example:

• Column A has 2,500 entries
• Column B has 2,700 entries, along with 2 additional columns of related data in Column C & D
• (after the macro is run) Column E has 200 entries extracted from List B that are not present in List A, AND the data from Column C & D is now in Column F & G.

Thoughts?

MuchoBrento

 

[Trebor76]

Hi there,

It worked for me albeit only on a small test dataset.

Thoughts?

Perhaps do what the macro is doing which is to use the COUNTIF function and where the result is zero from list 1 to list 2 put that value in column C. This is then repeated for list2 to list1 which maybe incorrect logic. I may have to see your workbook to provide an answer.

Robert

 

[Trebor76]

It's late in Oz now but try this and I'll check in tomorrow morning to check how it went:

Option Explicit
Sub Macro1()

    Const lngStartRow As Long = 2 'Starting row for the data. Change to suit.

    Dim lngEndRow As Long
    Dim rngCell As Range
    Dim rngMyRange As Range
    Dim strOutputCol As String
    Dim lngMyCounter As Long
        
    lngEndRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngMyRange = Range("A" & lngStartRow & ":B" & lngEndRow)
    strOutputCol = "E" 'Column for output. Change to suit.
    
    Application.ScreenUpdating = False
    
    'Clear any existing entries from previous runs
    If Cells(Rows.Count, strOutputCol).End(xlUp).Row >= lngStartRow Then
        Range(strOutputCol & lngStartRow & ":" & strOutputCol & Cells(Rows.Count, strOutputCol).End(xlUp).Row).ClearContents
    End If
    
    For Each rngCell In rngMyRange
        If Evaluate("COUNTIF(" & rngMyRange.Address & "," & rngCell.Address & ")") = 1 Then
            lngMyCounter = lngMyCounter + 1
            If lngMyCounter = 1 Then
                Range(strOutputCol & lngStartRow).Value = rngCell.Value
            Else
                Range(strOutputCol & Rows.Count).End(xlUp).Offset(1, 0).Value = rngCell.Value
            End If
        End If
    Next rngCell
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[muchobrento]

Hey Robert.

I'm still not able to get a list of just unique items. When I run the macro, it still has the same problem. Additionally, the results didn't post the adjacent info into Columns F & G that was supposed to "stay" with the data posted to Column E.

It can be tough to figure these things out remotely. I made a screencast of what I'm seeing from my end. Maybe it'll help. Here's the link: https://www.screenr.com/1SQN

Thanks again!

 

[Kyle123]

Do columns A and B have duplicates in their own column or is the data in each of these likely to be unique?

Try this, it's not especially efficient but I think it does the job:

Option Explicit
Sub test()

    Dim list1, list2, Key
    Dim x As Long, y As Long
    Dim dic1 As Object, dic2 As Object, outp As Object
    
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    Set outp = CreateObject("scripting.dictionary")
    
    list1 = Range("A2:A10001").Value2 'Change to the actual Range
    list2 = Range("B2:B86006").Value2 'Change to the actual Range
    
    
    For x = LBound(list1) To UBound(list1)
        If Not dic1.exists(list1(x, 1)) Then
            dic1.Add list1(x, 1), Nothing
        End If
    Next x
    
    For x = LBound(list2) To UBound(list2)
        If Not dic2.exists(list2(x, 1)) Then
            dic2.Add list2(x, 1), Nothing
        End If
    Next x
    
    For Each Key In dic1
        If Not dic2.exists(Key) Then outp.Add Key, Nothing
    Next Key
    
    For Each Key In dic2
        If Not dic1.exists(Key) Then outp.Add Key, Nothing
    Next Key
    
    Range("C2").Resize(outp.Count, 1).Value = Application.Transpose(outp.keys())
    
End Sub

 

[Trebor76]

OK - as well as Kyle123's nifty solution try this:

Option Explicit
Sub Macro3()

    Const lngStartRow As Long = 2 'Starting row for the data. Change to suit.
    
    Dim lngEndRow As Long
    Dim lngMyRow As Long
            
    lngEndRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      
    Application.ScreenUpdating = False
    
    'Clear any existing entries from previous runs
    If Cells(Rows.Count, "E").End(xlUp).Row >= lngStartRow Then
        Range("E2:E" & Cells(Rows.Count, "E").End(xlUp).Row).ClearContents
    End If
    
    For lngMyRow = lngStartRow To lngEndRow
        If Len(Range("A" & lngMyRow)) > 0 Then
            If IsError(Evaluate("VLOOKUP(A" & lngMyRow & ",$B$" & lngStartRow & ":$B$" & lngEndRow & ",1,FALSE)")) = True Then
                With Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
                    .Font.Color = RGB(0, 0, 255) 'Blue font to show those values from column A not in column B. Change to suit.
                    .Value = Range("A" & lngMyRow)
                End With
            End If
        End If
        If Len(Range("B" & lngMyRow)) > 0 Then
            If IsError(Evaluate("VLOOKUP(B" & lngMyRow & ",$A$" & lngStartRow & ":$A$" & lngEndRow & ",1,FALSE)")) = True Then
                With Range("E" & Rows.Count).End(xlUp).Offset(1, 0)
                    .Font.Color = RGB(255, 0, 0) 'Red font to show those values from column B not in column A. Change to suit.
                    .Value = Range("B" & lngMyRow)
                End With
            End If
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True
    
    MsgBox "All non matching entries between columns A and B have now been outputted to column E.", vbInformation
    
End Sub

Note the different font colours as a reference to show which column (A or B) each item in column E has come from.

If this is still not right I will need your workbook with a before and after scenario in it. If can have that I'm fairly sure I'll be able to provide a solution.

Regards,

Robert