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
