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




Reply With Quote

Bookmarks