VBA Program to Compare 4 Columns in Excel (Required)

[vijaysram]

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


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]

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]

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]

Try this


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]

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]

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]

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]

Try this


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).Va lue = 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]

Here's a revised one


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).Va lue = 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]

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/23259414/Compare%20columns.xlsm

[Admin]

Hi Vijay,

Please do not quote the entire post unless it is relevant.
You may also try this code.


Option Explicit

Sub kTest()

Dim ResultCol As Long
Dim Cols2Compare As String
Dim d, i As Long, Dic() As Object
Dim x, j As Long, UB As Long


Cols2Compare = Application.InputBox("Enter the columns to compare", "Compare Columns", "1,3,5,6", Type:=2)

If Cols2Compare = "False" Or Cols2Compare = "" Then Exit Sub

ResultCol = Application.InputBox("Enter the result column", "Compare Columns", 10, Type:=1)

If ResultCol = 0 Then Exit Sub

x = Split(Cols2Compare, ",")
UB = UBound(x)
If UB < 1 Then
MsgBox "Minimum 2 columns required", vbInformation
Exit Sub
End If

For i = 0 To UB
ReDim Preserve Dic(i)
Set Dic(i) = CreateObject("scripting.dictionary")
Dic(i).comparemode = 1
Next

d = Range("a1").CurrentRegion.Value2

For j = 0 To UB
For i = 1 To UBound(d, 1) 'replace 1 with 2 if the data have column headers
Select Case j
Case 0
If Len(d(i, x(j))) Then
Dic(0).Item(d(i, x(j))) = True
End If
Case Else
If Dic(j - 1).exists(d(i, x(j))) Then
Dic(j).Item(d(i, x(j))) = True
End If
End Select
Next
Next

If Dic(UB).Count Then
j = Dic(UB).Count
Cells(1, ResultCol) = "Result"
Cells(2, ResultCol).Resize(j) = Application.Transpose(Dic(UB).keys)
Cells(2, ResultCol).Resize(j).Sort Cells(2, ResultCol), 1
End If

End Sub

[vijaysram]

Thank you so much for your kind assistance..It helps me to save a lot of time :-)%D