VBA Program to Compare 4 Columns in Excel (Required)

**vijaysram** · 06-19-2013, 11:21 PM

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

**Excel Fox** · 06-20-2013, 12:16 AM

Hi vijaysram, welcome to Excel Fox community

So what will be the comparison? Is it just a simple equating of values, like, if A1=B1=C1=D1, then True, else False?

**vijaysram** · 06-20-2013, 08:04 AM

Originally Posted by Excel Fox

Hi vijaysram, welcome to Excel Fox community

So what will be the comparison? Is it just a simple equating of values, like, if A1=B1=C1=D1, then True, else False?

Hi Exelfox, 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.

I tried the above concept before posting this question on this forum but my excel got hang when i started running using above concept. Somewhere i am missing when i am converting the concept into a program. Can you please help me how to program the above concept..

**Excel Fox** · 06-20-2013, 11:12 AM

Try this

Code:

Private Sub CommandButton1_Click()

    Dim lngColumnIndex() As Long
    Dim lngLoop As Long, lngSelected As Long, lngRows As Long
    Dim strColumnHeaders As String, strSelected As String
    Dim blnHoldsTrue As Boolean
    Const lngColumnHeaderRow As Long = 1
    Const lngColumnsToCompare As Long = 4
    
    On Error GoTo Err
    ReDim lngColumnIndex(1 To lngColumnsToCompare + 1)
    For lngLoop = 1 To ActiveSheet.UsedRange.Columns.Count
        strColumnHeaders = strColumnHeaders & lngLoop & " - " & Cells(lngColumnHeaderRow, lngLoop).Value & "|"
    Next lngLoop
    strColumnHeaders = "The column headers are " & vbLf & vbLf & Join(Split(strColumnHeaders, "|"), vbLf) & vbLf
    For lngLoop = 1 To lngColumnsToCompare
        For lngSelected = 1 To lngLoop - 1
            strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
        Next lngSelected
        lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter each column index one by one", "Column Compare")
        strSelected = "You have already selected:" & vbLf & vbLf
    Next lngLoop
    
    For lngSelected = 1 To lngLoop - 1
        strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
    Next lngSelected
    lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter column index where you want to show the comparison result", "Column Compare")
    lngRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    blnHoldsTrue = True
    For lngRows = lngColumnHeaderRow + 1 To lngRows
        For lngLoop = 2 To lngColumnsToCompare
            blnHoldsTrue = blnHoldsTrue And (Cells(lngRows, lngColumnIndex(lngLoop)).Value = Cells(lngRows, lngColumnIndex(lngLoop - 1)).Value)
        Next lngLoop
        Cells(lngRows, lngColumnIndex(lngLoop)).Value = blnHoldsTrue
        blnHoldsTrue = True
    Next lngRows
    Exit Sub
Err:    MsgBox "Either cancelled by user, or incorrect entry made." & vbLf & vbLf & "If neither of these, unexpected error!", vbOKOnly + vbInformation, ""
    
End Sub

**vijaysram** · 06-20-2013, 11:08 PM

I tried the above VBA code but it is not working as expected.. It is finding the duplicate values only when all the rows having the same data.. suppose if a column A on cell A25 is having value 56 & B85 is having value 56 , C23 is having a value of 56 and d83 is having a value of 56 then the program is not finding it as duplicate value. It is matching as duplicate value only when A25 = B25=C25=D25 = 56. Can you please sort this problem

**Excel Fox** · 06-20-2013, 11:49 PM

So if a value is found on all 4 columns, on which row in the 5th column do we write the output? And which column do we use to consider as base comparison value? Column A?

**vijaysram** · 06-21-2013, 07:32 AM

Originally Posted by Excel Fox

So if a value is found on all 4 columns, on which row in the 5th column do we write the output? And which column do we use to consider as base comparison value? Column A?

Hi

The Macro should ask us for the input of the column name which we need to put the result. The result can be displayed as per sort : smallest to largest so it will be easy. You may consider base comparison value A or the First column name which we input. The macro should be in such a way i can able to input any column names to compare. Accordingly it need to compare the columns and put the result on the desired result column.

If the VBA can be designed as per the below way it will be really useful for me for future use..i.e. not only for 4 columns i may use if for multiple columns in future

1) Enter the number of columns to compare ( Suppose if i select 8 columns to compare)
2) Enter the First Column name to compare
3) Enter the Second Column name to compare
4) Enter the Third Column name to compare
5) Enter the Fourth Column name to compare
6) Enter the Fifth Column name to compare
7) Enter the Sixth Column name to compare
8) Enter the Seventh Column name to compare
9) Enter the Eighth Column name to compare
10) Enter the column name to put the result

**Excel Fox** · 06-21-2013, 01:24 PM

Try this

Code:

Private Sub CommandButton1_Click()

    Dim lngColumnIndex() As Long
    Dim lngLoop As Long
    Dim lngSelected As Long
    Dim lngRows As Long
    Dim lngUniqueIndex As Long
    Dim strColumnHeaders As String
    Dim strSelected As String
    Dim blnHoldsTrue As Boolean
    Dim lngColumnsToCompare As Long
    Dim varUniques As Variant
    Const lngColumnHeaderRow As Long = 1
    
    lngColumnsToCompare = InputBox("Enter the number of columns to compare")
    If lngColumnsToCompare < 2 Then
        MsgBox "Minimum 2 columns required", vbOKOnly + vbInformation, "": Exit Sub
    End If
    On Error GoTo Err
    ReDim lngColumnIndex(1 To lngColumnsToCompare + 1)
    For lngLoop = 1 To ActiveSheet.UsedRange.Columns.Count
        strColumnHeaders = strColumnHeaders & lngLoop & " - " & Cells(lngColumnHeaderRow, lngLoop).Value & "|"
    Next lngLoop
    strColumnHeaders = "The column headers are " & vbLf & vbLf & Join(Split(strColumnHeaders, "|"), vbLf) & vbLf
    For lngLoop = 1 To lngColumnsToCompare
        For lngSelected = 1 To lngLoop - 1
            strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
        Next lngSelected
        lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter each column index one by one", "Column Compare")
        strSelected = "You have already selected:" & vbLf & vbLf
    Next lngLoop
    
    For lngSelected = 1 To lngLoop - 1
        strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
    Next lngSelected
    lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter column index where you want to show the comparison result", "Column Compare")
    lngRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ReDim varUniques(1 To lngRows)
    blnHoldsTrue = True
    For lngRows = lngColumnHeaderRow + 1 To lngRows
        For lngLoop = 2 To lngColumnsToCompare
            blnHoldsTrue = blnHoldsTrue And (Cells(lngRows, lngColumnIndex(lngLoop)).Value = Cells(lngRows, lngColumnIndex(lngLoop - 1)).Value)
        Next lngLoop
        If blnHoldsTrue Then
            lngUniqueIndex = lngUniqueIndex + 1
            varUniques(lngUniqueIndex) = Cells(lngRows, lngColumnIndex(lngLoop - 1)).Value
        Else
            blnHoldsTrue = True
        End If
    Next lngRows
    ReDim Preserve varUniques(1 To lngUniqueIndex)
    Cells(lngColumnHeaderRow + 1, lngColumnIndex(lngLoop)).Resize(lngRows - lngColumnHeaderRow).ClearContents
    Cells(lngColumnHeaderRow + 1, lngColumnIndex(lngLoop)).Resize(lngUniqueIndex).Value = Application.Transpose(varUniques)
    Exit Sub
Err:    MsgBox "Either cancelled by user, or incorrect entry made." & vbLf & vbLf & "If neither of these, unexpected error!", vbOKOnly + vbInformation, ""
    
End Sub

**Excel Fox** · 06-21-2013, 05:17 PM

Here's a revised one

Code:

Private Sub CommandButton1_Click()

    Dim lngColumnIndex() As Long
    Dim lngLoop As Long
    Dim lngSelected As Long
    Dim lngRows As Long
    Dim lngTotalRows As Long
    Dim lngUniqueIndex As Long
    Dim strColumnHeaders As String
    Dim strSelected As String
    Dim blnHoldsTrue As Boolean
    Dim lngColumnsToCompare As Long
    Dim varUniques As Variant
    Const lngColumnHeaderRow As Long = 1
    
    lngColumnsToCompare = InputBox("Enter the number of columns to compare")
    If lngColumnsToCompare < 2 Then
        MsgBox "Minimum 2 columns required", vbOKOnly + vbInformation, "": Exit Sub
    End If
    On Error GoTo Err
    ReDim lngColumnIndex(1 To lngColumnsToCompare + 1)
    For lngLoop = 1 To ActiveSheet.UsedRange.Columns.Count
        strColumnHeaders = strColumnHeaders & lngLoop & " - " & Cells(lngColumnHeaderRow, lngLoop).Value & "|"
    Next lngLoop
    strColumnHeaders = "The column headers are " & vbLf & vbLf & Join(Split(strColumnHeaders, "|"), vbLf) & vbLf
    For lngLoop = 1 To lngColumnsToCompare
        For lngSelected = 1 To lngLoop - 1
            strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
        Next lngSelected
        lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter each column index one by one", "Column Compare")
        strSelected = "You have already selected:" & vbLf & vbLf
    Next lngLoop
    
    For lngSelected = 1 To lngLoop - 1
        strSelected = strSelected & lngColumnIndex(lngSelected) & vbLf
    Next lngSelected
    lngColumnIndex(lngLoop) = InputBox(strColumnHeaders & strSelected & "Enter column index where you want to show the comparison result", "Column Compare")
    lngTotalRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    ReDim varUniques(1 To lngTotalRows)
    blnHoldsTrue = True
    For lngRows = lngColumnHeaderRow + 1 To lngTotalRows
        For lngLoop = 2 To lngColumnsToCompare
            blnHoldsTrue = blnHoldsTrue And (IsNumeric(Application.Match(Cells(lngRows, lngColumnIndex(lngLoop - 1)).Value, Cells(lngColumnHeaderRow + 1, lngColumnIndex(lngLoop)).Resize(lngTotalRows - lngColumnHeaderRow), 0)))
        Next lngLoop
        If blnHoldsTrue Then
            lngUniqueIndex = lngUniqueIndex + 1
            varUniques(lngUniqueIndex) = Cells(lngRows, lngColumnIndex(1)).Value
        Else
            blnHoldsTrue = True
        End If
    Next lngRows
    ReDim Preserve varUniques(1 To lngUniqueIndex)
    Cells(lngColumnHeaderRow + 1, lngColumnIndex(lngLoop)).Resize(lngTotalRows - lngColumnHeaderRow).ClearContents
    Cells(lngColumnHeaderRow + 1, lngColumnIndex(lngLoop)).Resize(lngUniqueIndex).Value = Application.Transpose(varUniques)
    Exit Sub
Err:    MsgBox "Either cancelled by user, or incorrect entry made." & vbLf & vbLf & "If neither of these, unexpected error!", vbOKOnly + vbInformation, ""
    
End Sub

**vijaysram** · 06-21-2013, 11:25 PM

Hi

Something problem with the code.. It is not comparing properly and giving incorrect values. Please find the attached sheet and try running the code..

https://dl.dropboxusercontent.com/u/...20columns.xlsm