VBA Program to Compare 4 Columns in Excel (Required)

SICAudio03: how do you define 'unique'? Do you mean non-duplicate values (i.e. if the name "Jeff" is repeated, then it is NOT unique and therefore won't be included in the output" or do you mean a complete list of items (something I call 'Distinct', i.e. if the name "Jeff is repeated 3 times, it will only appear once in the output)?
 
Hi Jeff, thank you for your response. Let me see if I can clear things up a bit. By unique values i mean non-duplicate values; if list "Master" contains a value and that same value is not found in list "Search" I need to have the value from list "Master" exported to a new list. Second note, the data that I need to match is actually located across 3 columns which have identical headings in each list: "Part Number", "Location", & "Sum of Quantity". I need to match the data for all 3 of these columns, sort of like matching 1 row to another. I am uploading a test file. Please let me know if you need any more info.

Thanks
 

Attachments

  • SICAudio03 Comparison.xlsx
    36.3 KB · Views: 41
cool. Here's some code that should do it. It's fairly complicated, on account for I've written it so that you can either a) select a contiguous block (i.e. a bunch of columns that are side by side and have the same amount of rows) or b) select different sized ranges from separate locations.

Run the sub UniqueItems, which in turn calls another couple of routines.

Code: 
Sub UniqueItems()

    Dim rngOutput As Range
    Dim dic_A As Object    
    Dim dic_B As Object
    Dim lng As Long
    Dim lngRange As Long
    Dim varItems As Variant
    Dim strMessage As String

    varItems = False
    On Error Resume Next
    Set varItems = Application.InputBox _
                    (Title:="Select Output cell", _
                     Prompt:="Where do you want the duplicates to be output?", Type:=8)
    If Err.Number = 0 Then 'user didn't push cancel
        On Error GoTo 0
        Set rngOutput = varItems
        Set dic_A = CreateObject("Scripting.Dictionary")
        Set dic_B = CreateObject("Scripting.Dictionary")

        strMessage = "Select the first range that you want to compare."
        strMessage = strMessage & vbNewLine & vbNewLine
        strMessage = strMessage & "If your ranges form a contiguous block (i.e. the ranges are side-by-side), select the entire block."
      
        varItems = Application.InputBox(Title:="Select first range...", _
                                        Prompt:=strMessage, _
                                        Type:=8)

       If VarType(varItems) <> vbBoolean Then 'User didn't cancel

            If UBound(varItems, 2) > 1 Then 'Data is in a contigous block
                UniqueDictionary varItems, lngRange, dic_A, dic_B
            Else
                'User will select individual blocks in an endless loop
               'that will only be escaped when they push Cancel
               lngRange = 1
               UniqueDictionary varItems, lngRange, dic_A, dic_B

                Do Until "Hell" = "Freezes Over" 'We only want to exit the loop once the user pushes Cancel
                    lngRange = lngRange + 1
                    strMessage = "Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to compare."
                    strMessage = strMessage & vbNewLine & vbNewLine
                    strMessage = strMessage & "If you have no more ranges to add, push Cancel"
                    varItems = Application.InputBox(Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
                                                        Prompt:=strMessage, _
                                                        Type:=8)
                    If VarType(varItems) = vbBoolean Then
                        lngRange = lngRange - 1
                        Exit Do
                    Else:
                        UniqueDictionary varItems, lngRange, dic_A, dic_B
                    End If
                Loop

            End If 'If UBound(varItems, 2) > 1 Then

            'Write any duplicate items back to the worksheet.
                If dic_B.Count > 0 Then
                    rngOutput.Resize(dic_B.Count) = Application.Transpose(dic_B.Items)
                Else:
                    MsgBox "There were no numbers unique to all " & lngRange & " columns."
                End If
            
            End If 'If VarType(varItems) <> vbBoolean Then 'User didn't cancel
        End If 'If Err.Number = 0 Then 'user didn't push cancel

    'Cleanup
    Set dic_A = Nothing
    Set dic_B = Nothing




End Sub


Private Function UniqueDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)

    Dim lng As Long
    Dim dic_dedup As Object
    Dim varItem As Variant
    Dim lPass As Long
    Set dic_dedup = CreateObject("Scripting.Dictionary")

    For [I]lPass[/I] = 1 To UBound(varItems, 2)
        If UBound(varItems, 2) > 1 Then lngRange = lngRange + 1
            For lng = 1 To UBound(varItems)
                If Not dic_A.exists(varItems(lng, lPass)) Then
                    dic_A.Add varItems(lng, lPass), varItems(lng, lPass)
                    dic_B.Add varItems(lng, lPass), varItems(lng, lPass)
                Else
                    If dic_B.exists(varItems(lng, lPass)) Then dic_B.Remove varItems(lng, lPass)
                End If
            Next

    Next


End Function

Function OrdinalSuffix(ByVal Num As Long) As String
'Code from http://www.cpearson.com/excel/ordinal.aspx

        Dim N As Long
        Const cSfx = "stndrdthththththth" ' 2 char suffixes
        N = Num Mod 100
        If ((Abs(N) >= 10) And (Abs(N) <= 19)) _
                Or ((Abs(N) Mod 10) = 0) Then
            OrdinalSuffix = "th"
        Else
            OrdinalSuffix = Mid(cSfx, _
                ((Abs(N) Mod 10) * 2) - 1, 2)
        End If
    End Function
 
Last edited:
Forgot to mention that if you have more than 65,536 non-duplicates, then due to an error between VBA and Excel, the above won't work. I'll whip up the necessary modifications to work around this limit as time permits.
 
Time permits. Here 'tis
Code: 
Sub UniqueItems()

    Dim rngOutput As Range
    Dim dic_A As Object
    Dim dic_B As Object
    Dim lng As Long
    Dim lngRange As Long
    Dim varItems As Variant
    Dim strMessage As String

    varItems = False
    On Error Resume Next
    Set varItems = Application.InputBox _
                    (Title:="Select Output cell", _
                     Prompt:="Where do you want the duplicates to be output?", Type:=8)
    If Err.Number = 0 Then 'user didn't push cancel
        On Error GoTo 0
        Set rngOutput = varItems
        Set dic_A = CreateObject("Scripting.Dictionary")
        Set dic_B = CreateObject("Scripting.Dictionary")

        strMessage = "Select the first range that you want to compare."
        strMessage = strMessage & vbNewLine & vbNewLine
        strMessage = strMessage & "If your ranges form a contiguous block (i.e. the ranges are side-by-side), select the entire block."
      
        varItems = Application.InputBox(Title:="Select first range...", _
                                        Prompt:=strMessage, _
                                        Type:=8)

       If VarType(varItems) <> vbBoolean Then 'User didn't cancel

            If UBound(varItems, 2) > 1 Then 'Data is in a contigous block
                UniqueDictionary varItems, lngRange, dic_A, dic_B
            Else
                'User will select individual blocks in an endless loop
               'that will only be escaped when they push Cancel
               lngRange = 1
               UniqueDictionary varItems, lngRange, dic_A, dic_B

                Do Until "Hell" = "Freezes Over" 'We only want to exit the loop once the user pushes Cancel
                    lngRange = lngRange + 1
                    strMessage = "Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to compare."
                    strMessage = strMessage & vbNewLine & vbNewLine
                    strMessage = strMessage & "If you have no more ranges to add, push Cancel"
                    varItems = Application.InputBox(Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
                                                        Prompt:=strMessage, _
                                                        Type:=8)
                    If VarType(varItems) = vbBoolean Then
                        lngRange = lngRange - 1
                        Exit Do
                    Else:
                        UniqueDictionary varItems, lngRange, dic_A, dic_B
                    End If
                Loop

            End If 'If UBound(varItems, 2) > 1 Then

            'Write any duplicate items back to the worksheet.
                       
            
            
                If dic_B.Count > 0 Then
                    
                    If dic_B.Count < 65537 Then
                        rngOutput.Resize(dic_B.Count) = Application.Transpose(dic_B.Items)
                    Else
                        'The dictionary is too big to transfer to the workheet
                        ' because Application.Transfer can't handle more than
                        ' 65536 items.
                        ' So we'll transfer it to a variant array, then transfer
                        ' that array to the worksheet.
                        ReDim varOutput(1 To dic_B.Count, 1 To 1)
                        For lng = 1 To dic_B.Count
                            varOutput(lng, 1) = dic_B.Item(lng)
                        Next lng
                        rngOutput.Resize(dic_B.Count) = varOutput
                    End If
                Else:
                    MsgBox "There were no numbers unique to all " & lngRange & " columns."
                End If
            
            End If 'If VarType(varItems) <> vbBoolean Then 'User didn't cancel
        End If 'If Err.Number = 0 Then 'user didn't push cancel

    'Cleanup
    Set dic_A = Nothing
    Set dic_B = Nothing




End Sub


Private Function UniqueDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)

    Dim lng As Long
    Dim dic_dedup As Object
    Dim varItem As Variant
    Dim lPass As Long
    Set dic_dedup = CreateObject("Scripting.Dictionary")

    For lPass = 1 To UBound(varItems, 2)
        If UBound(varItems, 2) > 1 Then lngRange = lngRange + 1
            For lng = 1 To UBound(varItems)
                If Not dic_A.exists(varItems(lng, lPass)) Then
                    dic_A.Add varItems(lng, lPass), varItems(lng, lPass)
                    dic_B.Add varItems(lng, lPass), varItems(lng, lPass)
                Else
                    If dic_B.exists(varItems(lng, lPass)) Then dic_B.Remove varItems(lng, lPass)
                End If
            Next

    Next


End Function

Function OrdinalSuffix(ByVal Num As Long) As String
'Code from http://www.cpearson.com/excel/ordinal.aspx

        Dim N As Long
        Const cSfx = "stndrdthththththth" ' 2 char suffixes
        N = Num Mod 100
        If ((Abs(N) >= 10) And (Abs(N) <= 19)) _
                Or ((Abs(N) Mod 10) = 0) Then
            OrdinalSuffix = "th"
        Else
            OrdinalSuffix = Mid(cSfx, _
                ((Abs(N) Mod 10) * 2) - 1, 2)
        End If
    End Function
 
Last edited:
Thanks Jeff. The code works very well except for one issue. Currently "unique values" are being returned from both the "Master" and "Compare" columns. I only want the code to return unique values from the "Master" column. I am putting a crude example below. "Unique Values" from only the "Master" column get copied to the "Results" column. ("unique values" below are highlighted in red)

"Master"
"Search""Results"
1
12
235
346
4
78
59
610
7
8
9
10

This is the only issue that I can see everything else works flawlessly. Hopefully this won't be too difficult to fix. Thank you for your time and effort in helping me with this.

Thank you,
 
Ahh. I thought you wanted to return the unique values from ALL columns. Okay, will amend.
 
This should do it:
Code: 
Option Explicit

Sub UniqueItems_FirstList()

    Dim rngOutput As Range
    Dim dic_A As Object
    Dim dic_B As Object
    Dim lng As Long
    Dim lPass As Long
    Dim lngRange As Long
    Dim varItem As Variant
    Dim varItems As Variant
    Dim strMessage As String

    varItems = False
    On Error Resume Next
    Set varItems = Application.InputBox _
                    (Title:="Select Output cell", _
                     Prompt:="Where do you want the unique items to be output?", Type:=8)
    If Err.Number = 0 Then 'user didn't push cancel
        On Error GoTo 0
        Set rngOutput = varItems
        Set dic_A = CreateObject("Scripting.Dictionary")
        Set dic_B = CreateObject("Scripting.Dictionary")

        
        lngRange = 1
        Do Until "Hell" = "Freezes Over"    'We only want to exit the loop once the user pushes Cancel,
                                            ' or if their initial selection was a 2D range
            Select Case lngRange
                Case 1: strMessage = vbNewLine & vbNewLine & "If your ranges form a contiguous block (i.e. the ranges are side-by-side), select the entire block."
                Case 2: strMessage = ""
                Case Else: strMessage = vbNewLine & vbNewLine & "If you have no more ranges to add, push Cancel"
            End Select
            
            varItems = Application.InputBox(Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
                                                Prompt:="Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to process." & strMessage, _
                                                Type:=8)
            If VarType(varItems) = vbBoolean Then
                lngRange = lngRange - 1
                If lngRange = 0 Then GoTo errhandler:
                Exit Do
            Else:
                For lPass = 1 To UBound(varItems, 2)
                    For lng = 1 To UBound(varItems)
                        If lngRange = 1 Then 'First pass
                            If Not dic_A.exists(varItems(lng, lPass)) Then
                                dic_A.Add varItems(lng, lPass), varItems(lng, lPass)
                            Else: dic_A.Remove varItems(lng, lPass) 'Item is duplicated within the first column
                            End If
                        Else 'Subsequent pass
                            If Not dic_B.exists(varItems(lng, lPass)) Then dic_B.Add varItems(lng, lPass), varItems(lng, lPass)
                        End If
                    Next lng
                    lngRange = lngRange + 1
                Next lPass
    
                If UBound(varItems, 2) > 1 Then
                    lngRange = lngRange - 1
                    Exit Do 'Data is in a contigous block
                End If
            End If
            
        Loop

        'Try to add dic_A to dic_B. If we get an error, dic_A has a duplicate in another column
        
        For Each varItem In dic_A
            If dic_B.exists(varItem) Then dic_A.Remove (varItem)
        Next varItem
        
            'Write any remaining items back to the worksheet.
                       
        If dic_A.Count > 0 Then
            
            If dic_A.Count < 65537 Then
                rngOutput.Resize(dic_A.Count) = Application.Transpose(dic_A.Items)
            Else
                'The dictionary is too big to transfer to the workheet
                ' because Application.Transfer can't handle more than 65536 items.
                ' So we'll transfer it to a variant array, then transfer
                ' that array to the worksheet.
                ReDim varOutput(1 To dic_A.Count, 1 To 1)
                For lng = 1 To dic_A.Count
                    varOutput(lng, 1) = dic_A.Item(lng)
                Next lng
                rngOutput.Resize(dic_A.Count) = varOutput
            End If
        Else:
            MsgBox "There were no unique numbers across these " & lngRange & " columns."
        End If

    End If 'If Err.Number = 0 Then 'user didn't push cancel

    'Cleanup
    Set dic_A = Nothing
    Set dic_B = Nothing

errhandler:


End Sub


Private Function UniqueItems_FirstList_Dictionary(varItems As Variant, lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)

    Dim lng As Long
    Dim lPass As Long


    For lPass = 1 To UBound(varItems, 2)
        For lng = 1 To UBound(varItems)
            If lngRange = 1 Then 'First pass
                If Not dic_A.exists(varItems(lng, lPass)) Then
                    dic_A.Add varItems(lng, lPass), varItems(lng, lPass)
                Else: dic_A.Remove varItems(lng, lPass) 'Item is duplicated within the first column
                End If
            Else 'Subsequent pass
                If Not dic_B.exists(varItems(lng, lPass)) Then dic_B.Add varItems(lng, lPass), varItems(lng, lPass)
            End If
        Next
    Next
    


End Function

Note that if something appears in list A more than once, but is NOT in any of the other lists, it still gets counted as a duplicate, and so won't be returned. Is that the behavior you want, in that instance?
 
Hello. This code works very well but I have two requests. First, can you select the first column separately, and then have the others either a contiguous range or single columns. As it is, this code will stop at the first contiguous range, or if you select a single column first, then it will stop at the next contiguous selection. Second, for this code and the one before it, the end results are the unique items. I am trying to find those that are similar ie repeated somewhere. I have tried many things but cannot figure those. Thank you.
 
You must log in or register to reply here.
Back
Top