VBA Program to Compare 4 Columns in Excel (Required)

vijaysram

New member
Joined
Jun 19, 2013
Messages
6
Reaction score
0
Points
0
Hi all

I am New to VBA programming in Excel. Can someone please help me how to create a VBA Program to Compare 4 Columns in Excel and store the values in another column. I have searched it in multiple websites but i couldn't find it. I have got a VBA to compare 2 columns , please let me know how to create it for 4 columns

Code:
Private Sub CommandButton1_Click()
Dim CompareRange As Variant, To_Be_Compared As Variant, x As Variant, y As Variant
str1 = InputBox("Enter Column Name to be Compared")
str2 = InputBox("Enter Column Name to Compare")
str3 = InputBox("Enter Column Name to put the Result")
Range(str1 & "1").Select
Selection.End(xlDown).Select
Set To_Be_Compared = Range(str1 & "1:" & Selection.Address)
Range(str2 & "1").Select
Selection.End(xlDown).Select
Set CompareRange = Range(str2 & "1:" & Selection.Address)
i = 1
To_Be_Compared.Select
For Each x In Selection
For Each y In CompareRange
If x = y Then
Range(str3 & i).Value = x
i = i + 1
End If
Next y
Next x
End Sub
 
Last edited by a moderator:

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Hi vijaysram. Note that iterating through a long list using this code would take quite a bit of time, and that there are a few other approaches that will be much more efficient.

Before I start work on this, a couple of questions for you:


  1. Roughly how many rows are there in your data?
  2. Are you effectively only interested in finding duplicate values within the 4 lists? Do you want to return items that appear in all four lists, or that appear in any two of the four lists, or that appear in one 'master' list and also in one of the other 3?
 

vijaysram

New member
Joined
Jun 19, 2013
Messages
6
Reaction score
0
Points
0
Hi vijaysram. Note that iterating through a long list using this code would take quite a bit of time, and that there are a few other approaches that will be much more efficient.

Before I start work on this, a couple of questions for you:


  1. Roughly how many rows are there in your data?
  2. Are you effectively only interested in finding duplicate values within the 4 lists? Do you want to return items that appear in all four lists, or that appear in any two of the four lists, or that appear in one 'master' list and also in one of the other 3?

Hi Jeffey, Thanks for your Interest in assisting me. I have 8 columns of Data having maximum of 2500 rows in each column. My requirement is :

1) If I run the macro, it should ask me for the input of Column names to be compared and also should ask for the column where it need to put the result with the column heading as result.

2) The result which i expected on the result column is the common duplicate values found on all the 4 columns.
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Quick question: Are the items likely to be unique within a column? e.g. something like unique customer numbers etc. Or is it possible that there might be duplicates both within a column, and between columns?

Does each column hold the same type of data, or different? What's this actually for? (Often it helps me to conceptualize the problem and best solution if I have an idea of the real-world use).

Can you upload a sample spreadsheet containing the type of data you are working with?
 
Last edited:

vijaysram

New member
Joined
Jun 19, 2013
Messages
6
Reaction score
0
Points
0
Quick question: Are the items likely to be unique within a column? e.g. something like unique customer numbers etc. Or is it possible that there might be duplicates both within a column, and between columns?Does each column hold the same type of data, or different? What's this actually for? (Often it helps me to conceptualize the problem and best solution if I have an idea of the real-world use).Can you upload a sample spreadsheet containing the type of data you are working with?
Hi All the 4 columns will have similar type of data. i.e. Like Column A will have numbers from range 1 to 2500 and column B will have numbers from range 20 to 2500 and Column C will have numbers from range 230 to 2500 and column D will have numbers from range 40 to 2500. The prgrm needs to ask which of the 4 columns need to be checked.. I may need to compare either columnns A, B, C, D or E,F,G,N etc. Also, it may be have a option to compare to 6 columns and 8 columns in future..
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Hi Vijaysram.

This code will handle any number of ranges.

Keep adding ranges until you don't need any more, then push Cancel.
You can select whole columns, or particular ranges within a column.
The ranges don't even need to be the same size.

This was fun to code up. Thanks for the challenge, and let me know if you have any questions or issues.

Code:
Option Explicit
Option Base 1
Sub CompareRanges()


    Dim rngOutput As Range
    Dim rngAllLists As Range
    Dim dic1 As Object    ' We are using late binding. If we were using early binding we would have used this:  Dim dic As Scripting.Dictionary
    Dim dic2 As Object
    Dim lng As Long
    Dim lngRange As Long
    Dim varItems As Variant
    Dim strMessage As String
    Dim bExit As Boolean

    Set rngOutput = Application.InputBox _
                    (Title:="Select Output cell", _
                     Prompt:="Step 1: Select the cell where you want the output to start.", Type:=8)

    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    varItems = True

    Do Until bExit = True 'This won't actually ever get called
        lngRange = lngRange + 1
        strMessage = "Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to compare."
        If lngRange > 2 Then
            strMessage = strMessage & vbNewLine & vbNewLine
            strMessage = strMessage & "If you have no more ranges to add, push Cancel"
        End If

        varItems = Application.Transpose(Application.InputBox _
                                         (Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
                                          Prompt:=strMessage, _
                                          Type:=8))
        
        If VarType(varItems) = vbBoolean Then
            lngRange = lngRange - 1
            Exit Do
        End If
      

        If lngRange = 1 Then
            'First Pass: Just add the items to dic1
            For lng = 1 To UBound(varItems)
                If Not dic1.exists(varItems(lng)) Then dic1.Add varItems(lng), varItems(lng)
            Next
        ElseIf lngRange Mod 2 = 0 Then
            'Test if items in dic1, and IF SO then add them to dic2
            dic2.RemoveAll
            For lng = 1 To UBound(varItems)
                If dic1.exists(varItems(lng)) Then
                    If Not dic2.exists(varItems(lng)) Then dic2.Add varItems(lng), varItems(lng)
                End If
            Next
        Else
            'Test if items in dic2, and IF SO then add them to dic1
            dic1.RemoveAll
            For lng = 1 To UBound(varItems)
                If dic2.exists(varItems(lng)) Then
                    If Not dic1.exists(varItems(lng)) Then dic1.Add varItems(lng), varItems(lng)
                End If
            Next
        End If
    Loop

    'Write the remaining items back to the worksheet.
    If lngRange Mod 2 = 0 Then
        varItems = dic2.items
    Else
        varItems = dic1.items
    End If
    rngOutput.Resize(UBound(varItems)).Value = Application.Transpose(varItems)


    'Cleanup
    Set dic1 = Nothing
    Set dic2 = Nothing

End Sub
 

vijaysram

New member
Joined
Jun 19, 2013
Messages
6
Reaction score
0
Points
0
Hi Jeffrey

Thank you so much for your time and effort on this :)

I have tried to run the program but it was giving me error : " Compiler Error: Sub or Function not defined " and it is highlighting

"OrdinalSuffix" . I am using Office 2013.

Thanks again for your time..
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Whoops, sorry I forgot to include that sub.
Code:
Function OrdinalSuffix(ByVal Num As Long) As String
        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

Just pop this below the End Sub of the other routine. Sorry about that.
 

vijaysram

New member
Joined
Jun 19, 2013
Messages
6
Reaction score
0
Points
0
Thank you so much Jeffrey for your kind assistance..It helps me to save a lot of time :)
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Glad you like it, and happy to have helped. This code was fun to put together, and I'll be using it myself a lot.

Cheers

Jeff
 

rockies303

New member
Joined
Jan 9, 2014
Messages
2
Reaction score
0
Points
0
Hi Jeffrey,

Your code is exactly what I need as well, however, I keep getting this error:

Run-time error '9':
Subscript out of range

for this line:
If Not dic1.exists(varItems(lng)) Then dic1.Add varItems(lng), varItems(lng)

Any suggestions?
Any help is greatly appreciated. Thanks!

If Not dic1.exists(varItems(lng)) Then dic1.Add varItems(lng), varItems(lng)
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Hi Rockies303. Not sure why you would be getting that error. Can you send me some sample data to weir.jeff@gmail.com or upload a file somewhere and send me a link to it?

Also note that I found a bug in my original code.

You need to change this line:
rngOutput.Resize(UBound(varItems)).Value = Application.Transpose(varItems)
...to this:
rngOutput.Resize(UBound(varItems) + 1).Value = Application.Transpose(varItems)
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Vijaysram: Are you still monitoring this thread?

As per the further comments above, I found an error with the previous code that meant that the last duplicate item wasn't being dumped back into the spreadsheet. So if you had say the names "Jeff" and "Vijaysram" duplicated across columns, the last one would have been missed.

Sorry about that.

Here's the revised code that fixes this:

Code:
Option Explicit


Sub CompareRanges()


    Dim rngOutput As Range
    Dim dic_A As Object    ' We are using late binding. If we were using  early binding we would have used this:  Dim dic As Scripting.Dictionary
    Dim dic_B As Object
    Dim dic_Dedup As Object
    Dim lng As Long
    Dim lngRange As Long
    Dim varItem As Variant
    Dim varItems As Variant
    Dim strMessage As String


    varItems = False
    Set varItems = Application.InputBox _
                    (Title:="Select Output cell", _
                     Prompt:="Where do you want the duplicates to be output?", Type:=8)
    If Not VarType(varItems) = vbBoolean Then 'user didn't push cancel
        Set rngOutput = varItems

        Set dic_A = CreateObject("Scripting.Dictionary")
        Set dic_B = CreateObject("Scripting.Dictionary")
        Set dic_Dedup = CreateObject("Scripting.Dictionary")
        
    
        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."
            If lngRange > 2 Then
                strMessage = strMessage & vbNewLine & vbNewLine
                strMessage = strMessage & "If you have no more ranges to add, push Cancel"
            End If
    
            varItems = Application.Transpose(Application.InputBox _
                                             (Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
                                              Prompt:=strMessage, _
                                              Type:=8))
            
            If VarType(varItems) = vbBoolean Then
                lngRange = lngRange - 1
                Exit Do
            End If
          
    
            If lngRange = 1 Then
                'First Pass: Just add the items to dic_A
                For lng = 1 To UBound(varItems)
                    If Not dic_A.exists(varItems(lng)) Then dic_A.Add varItems(lng), varItems(lng)
                Next
                
            Else:
            ' Add items from current column to dic_Dedup so we can get rid of any duplicates within the column.
            ' Without this step, the code further below would think that intra-column duplicates were in fact
            ' duplicates ACROSS the columns processed to date
            For lng = 1 To UBound(varItems)
                If Not dic_Dedup.exists(varItems(lng)) Then dic_Dedup.Add varItems(lng), varItems(lng)
            Next
            
            End If
            
            'Find out which Dictionary currently contains our identified duplicate.
            ' This changes with each pass.
            '   *  On the first pass, we add the first list to dic_A
            '   *  On the 2nd pass, we attempt to add each new item to dic_A.
            '      If an item already exists in dic_A then we know it's a duplicate
            '      between lists, and so we add it to dic_B.
            '      When we've processed that list, we clear dic_A
            '   *  On the 3rd pass, we attempt to add each new item to dic_B,
            '      to see if it matches any of the duplicates already identified.
            '      If an item already exists in dic_B then we know it's a duplicate
            '      across all the lists we've processed to date, and so we add it to dic_A.
            '      When we've processed that list, we clear dic_B
            '   *  We keep on doing this until the user presses CANCEL.
           
            
            If lngRange Mod 2 = 0 Then
                'dic_A currently contains any duplicate items we've found in our passes to date
                
                'Test if item appears in dic_A, and IF SO then add it to dic_B
                For Each varItem In dic_Dedup
                    If dic_A.exists(varItem) Then
                        If Not dic_B.exists(varItem) Then dic_B.Add varItem, varItem
                    End If
                Next
                dic_A.RemoveAll
                dic_Dedup.RemoveAll
                
            Else
                'dic currently contains any duplicate items we've found in our passes to date
                
                'Test if item appear in dic_B, and IF SO then add it to dic_A
                For Each varItem In dic_Dedup
                    If dic_B.exists(varItem) Then
                        If Not dic_A.exists(varItem) Then dic_A.Add varItem, varItem
                    End If
                Next
                dic_B.RemoveAll
                dic_Dedup.RemoveAll
            End If
            
        Loop
    
        'Write any duplicate items back to the worksheet.
        If lngRange Mod 2 = 0 Then
            If dic_B.Count > 0 Then
                rngOutput.Resize(dic_B.Count) = Application.Transpose(dic_B.items)
            Else:
                MsgBox "There were no numbers common to all " & lngRange & " columns."
            End If
        Else
            If dic_A.Count > 0 Then
                rngOutput.Resize(dic_A.Count) = Application.Transpose(dic_A.items)
            Else:
                MsgBox "There were no numbers common to all " & lngRange & " columns."
            End If
        End If
    End If
    

    'Cleanup
    Set dic_A = Nothing
    Set dic_B = Nothing

End Sub

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:

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Rockies303:
Ahh. My code does something different than what you ask.


You can do what you need by concatenating the columns using a good seperator such as the pipe character | (which you get via shift + \ ) and then doing a MATCH or VLOOKUP for each item in each list on the other list.




So in D2 of each sheet, you would put this:
=A2&"|"&B2&"|"&C2

...and copy it down.


Then in E2 of the Original sheet you would put this:
=MATCH(D2,new!D2:$D$330,0)


And in E2 of the New sheet you would put this:

=MATCH(D2,original!$D$2:$D$322,0)


...and then you simply filter each list, looking for #N/A...which shows you when an item in that list doesn't appear in the other.

I'll think about a VBA solution that does this, but meanwhile, check my sheet.View attachment TEST-1.xls
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
I've reworked my original code so that it will process data is in a contiguous range, as well as non contiguous data

Code:
Sub CompareRanges()


    Dim rngOutput As Range
    Dim dic_A As Object    ' We are using late binding. If we were using early binding we would have used this:  Dim dic As Scripting.Dictionary
    Dim dic_B As Object
    Dim dic_dedup 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
                AddToDictionary 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
               AddToDictionary 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:
                        AddToDictionary 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 lngRange Mod 2 = 0 Then
                If dic_B.Count > 0 Then
                    rngOutput.Resize(dic_B.Count) = Application.Transpose(dic_B.Items)
                Else:
                    MsgBox "There were no numbers common to all " & lngRange & " columns."
                End If
            Else
                If dic_A.Count > 0 Then
                    rngOutput.Resize(dic_A.Count) = Application.Transpose(dic_A.Items)
                Else:
                    MsgBox "There were no numbers common 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 If
End Sub

Private Function AddToDictionary(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
        If lngRange = 1 Then
            'First Pass: Just add the items to dic_A
            For lng = 1 To UBound(varItems)
                If Not dic_A.exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
            Next
            
        Else:
                ' Add items from current column to dic_Dedup so we can get rid of any duplicates within the column.
                ' Without this step, the code further below would think that intra-column duplicates were in fact
                ' duplicates ACROSS the columns processed to date
                
                For lng = 1 To UBound(varItems)
                    If Not dic_dedup.exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
                Next
        
                 'Find out which Dictionary currently contains our identified duplicate.
                 ' This changes with each pass.
                 '   *  On the first pass, we add the first list to dic_A
                 '   *  On the 2nd pass, we attempt to add each new item to dic_A.
                 '      If an item already exists in dic_A then we know it's a duplicate
                 '      between lists, and so we add it to dic_B.
                 '      When we've processed that list, we clear dic_A
                 '   *  On the 3rd pass, we attempt to add each new item to dic_B,
                 '      to see if it matches any of the duplicates already identified.
                 '      If an item already exists in dic_B then we know it's a duplicate
                 '      across all the lists we've processed to date, and so we add it to dic_A.
                 '      When we've processed that list, we clear dic_B
                 '   *  We keep on doing this until the user presses CANCEL.
                
                 If lngRange Mod 2 = 0 Then
                     'dic_A currently contains any duplicate items we've found in our passes to date
                    
                     'Test if item appears in dic_A, and IF SO then add it to dic_B
                     For Each varItem In dic_dedup
                         If dic_A.exists(varItem) Then
                             If Not dic_B.exists(varItem) Then dic_B.Add varItem, varItem
                         End If
                     Next
                     dic_A.RemoveAll
                     dic_dedup.RemoveAll
    
                 Else
                     'dic_B currently contains any duplicate items we've found in our passes to date
                    
                     'Test if item appear in dic_B, and IF SO then add it to dic_A
                     For Each varItem In dic_dedup
                         If dic_B.exists(varItem) Then
                             If Not dic_A.exists(varItem) Then dic_A.Add varItem, varItem
                         End If
                     Next
                     dic_B.RemoveAll
                     dic_dedup.RemoveAll
            End If
         End If
    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
 

SICAudio03

New member
Joined
Jan 16, 2014
Messages
3
Reaction score
0
Points
0
Hi Jeffrey,

Your code is exactly what I need as well, except I need to return unique values not duplicates.

Any suggestions?
Any help is greatly appreciated. Thanks!
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Hi SICAudio03. I'll amend the code when I get a chance, and post back here.
 

JeffreyWeir

Super Moderator
Staff member
Joined
Mar 22, 2011
Messages
357
Reaction score
0
Points
0
Location
New Zealand
Hi again SICAudio03. Can you describe your requirements a bit further? For instance, is your data in one column, multiple columns side by side, or multiple columns in various places?

Note to self: Should be able to do this with two dictionaries:
We attempt to add all items to dicA
If dicA doesn't throw an error, then we add it to dicB
If dicA does throw an error, then we remove any pre-existing instance of that item from dicB
 
Last edited:
Top