Sub DuplicatesBetweenLists()
Dim rngOutput As Range
Dim dic_A As Object
Dim dic_B As Object
Dim dic_Output 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")
Set dic_Output = CreateObject("Scripting.Dictionary")
lngRange = 1
Do Until "Hell" = "Freezes Over" 'We only want to exit the loop once the user pushes Cancel,
' or if their initial selection was a 2D range
Select Case lngRange
Case 1: strMessage = vbNewLine & vbNewLine & "If your ranges form a contiguous block (i.e. the ranges are side-by-side), select the entire block."
Case 2: strMessage = ""
Case Else: strMessage = vbNewLine & vbNewLine & "If you have no more ranges to add, push Cancel"
End Select
varItems = Application.InputBox(Title:="Select " & lngRange & OrdinalSuffix(lngRange) & " range...", _
Prompt:="Select the " & lngRange & OrdinalSuffix(lngRange) & " range that you want to process." & strMessage, _
Type:=8)
If VarType(varItems) = vbBoolean Then
lngRange = lngRange - 1
If lngRange = 0 Then GoTo errhandler:
Exit Do
Else:
DuplicatesBetweenLists_AddToDictionary varItems, lngRange, dic_A, dic_B
If UBound(varItems, 2) > 1 Then
lngRange = lngRange - 1
Exit Do 'Data is in a contigous block
End If
End If
Loop
'Write any duplicate items back to the worksheet.
If lngRange Mod 2 = 0 Then
Set dic_Output = dic_B
Else: Set dic_Output = dic_A
End If
If dic_Output.Count > 0 Then
If dic_Output.Count < 65537 Then
rngOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items)
Else
'The dictionary is too big to transfer to the workheet
' because Application.Transfer can't handle more than 65536 items.
' So we'll transfer it to an appropriately oriented variant array,
' then transfer that array to the worksheet WITHOUT application.transpose
ReDim varOutput(1 To dic_Output.Count, 1 To 1)
For lng = 1 To dic_Output.Count
varOutput(lng, 1) = dic_Output.Item(lng)
Next lng
rngOutput.Resize(dic_Output.Count) = varOutput
End If 'If dic_Output.Count < 65537 Then
Else:
MsgBox "There were no numbers common to all " & lngRange & " columns."
End If 'If dic_Output.Count > 0 Then
End If 'If VarType(varItems) <> vbBoolean Then 'User didn't cancel
'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing
errhandler:
End Sub
Private Function DuplicatesBetweenLists_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 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 pass 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
lngRange = lngRange + 1
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
