Option Base 1
Sub CompareTwoLists()
'Purpose is to compare two lists and identify differences
'between them. Specifically, identify items in list1 that are
'not in list2 and vice-versa.
Dim rng As Range, rList1 As Range, rList2 As Range, cel As Range
Dim msg As String, unMatched1 As String, unMatched2 As String
Dim ctr1 As Long, ctr2 As Long, i As Long, j As Long, k As Long
Dim aList1(), aList2(), aComList(), comCtr As Long, test As Long
Dim rOutput1 As Range, rOutput2 As Range, rOutputCom As Range
msg = "To compare two lists, first use your mouse to select "
msg = msg & "the first list. Then, hold down the control key "
msg = msg & "and select the second list. Then click OK." & vbCrLf & vbCrLf
msg = msg & "NOTE: THIS COMPARISON IS NOT CASE SENSITIVE."
Application.ScreenUpdating = True 'Need for inputbox
Application.Calculation = xlCalculationManual
On Error Resume Next
Set rng = Application.InputBox(prompt:=msg, Type:=8, Title:="COMPARE TWO LISTS")
If Err.Number <> 0 Then Exit Sub 'Cancel was clicked
On Error GoTo 0
If rng.Areas.Count <> 2 Then
msg = "You must select two ranges and only two. Try again."
MsgBox msg
Exit Sub
End If
Application.ScreenUpdating = False
Set rList1 = rng.Areas(1)
Set rList2 = rng.Areas(2)
'First, compare list1 to list2 and single out items NOT in
'list2.
For Each cel In rList1
On Error Resume Next
test = WorksheetFunction.Match(cel.Value, rList2, 0)
If Err.Number <> 0 Then 'there was no match
unMatched1 = unMatched1 & "; " & cel.Value
ctr1 = ctr1 + 1
ReDim Preserve aList1(ctr1)
aList1(ctr1) = cel.Value
Else 'There is a match
comCtr = comCtr + 1
ReDim Preserve aComList(comCtr)
aComList(comCtr) = cel.Value
End If
On Error GoTo 0
Next cel
If ctr1 > 0 Then
msg = "There are " & ctr1 & " items in List1 that are not in List2." & vbCrLf & vbCrLf
MsgBox msg & Right(unMatched1, Len(unMatched1) - 1)
Application.ScreenUpdating = True
msg = "If you want these items placed in a separate list, select a cell to begin the list." & vbCrLf & vbCrLf
msg = msg & "Otherwise, click Cancel."
On Error Resume Next
Set rOutput1 = Application.InputBox(prompt:=msg, Type:=8, Title:="LIST ITEMS FROM LIST1 THAT HAVE NO MATCH IN LIST2")
If Err.Number = 0 Then
Application.ScreenUpdating = False
For i = 1 To UBound(aList1)
rOutput1.Offset(i, 0).Value = aList1(i)
Next i
With rOutput1
.Value = "Unique to List1"
.Font = "arial narrow"
.Font.Size = 10
.Font.Underline = True
.Font.Bold = True
End With
Range(rOutput1, rOutput1.End(xlDown)).Columns.AutoFit
End If
Application.ScreenUpdating = True
Else 'ctr1 =0
msg = "There are no items in List1 that are not in List2."
MsgBox msg
End If
On Error GoTo 0
'Now compare list2 to list1 and single out items from list2
'that are not in list1.
For Each cel In rList2
On Error Resume Next
test = WorksheetFunction.Match(cel.Value, rList1, 0)
If Err.Number <> 0 Then 'there was no match
unMatched2 = unMatched2 & "; " & cel.Value
ctr2 = ctr2 + 1
ReDim Preserve aList2(ctr2)
aList2(ctr2) = cel.Value
End If
On Error GoTo 0
Next cel
If ctr2 > 0 Then
msg = "There are " & ctr2 & " items in List2 that are not in List1." & vbCrLf & vbCrLf
MsgBox msg & Right(unMatched2, Len(unMatched2) - 1)
Application.ScreenUpdating = True
msg = "If you want these items placed in a separate list, select a cell to begin the list." & vbCrLf & vbCrLf
msg = msg & "Otherwise, click Cancel."
On Error Resume Next
Set rOutput2 = Application.InputBox(prompt:=msg, Type:=8, Title:="LIST ITEMS FROM LIST2 THAT HAVE NO MATCH IN LIST1")
If Err.Number = 0 Then
Application.ScreenUpdating = False
For j = 1 To UBound(aList2)
rOutput2.Offset(j, 0).Value = aList2(j)
Next j
With rOutput2
.Value = "Unique to List2"
.Font = "arial narrow"
.Font.Size = 10
.Font.Underline = True
.Font.Bold = True
End With
Range(rOutput2, rOutput2.End(xlDown)).Columns.AutoFit
End If
Else 'ctr2 =0
msg = "There are no items in List2 that are not in List1."
MsgBox msg
End If
'Optionally, list common items if there are a large number
'of unique items between the two lists.
If comCtr > 0 Then
Application.ScreenUpdating = True
msg = "There are " & comCtr & " COMMON ITEMS among the two lists." & vbCrLf
msg = msg & "Select a cell if you want to list them, otherwise click Cancel."
On Error Resume Next
Set rOutputCom = Application.InputBox(prompt:=msg, Type:=8, Title:="LIST COMMON ITEMS")
If Err.Number = 0 Then
Application.ScreenUpdating = False
For k = 1 To UBound(aComList)
rOutputCom.Offset(k, 0).Value = aComList(k)
Next k
With rOutputCom
.Value = "Common to Both Lists"
.Font = "arial narrow"
.Font.Size = 10
.Font.Underline = True
.Font.Bold = True
End With
Range(rOutputCom, rOutputCom.End(xlDown)).Columns.AutoFit
End If
End If
rng.Cells(1, 1).Select
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
