Identifying duplicates between multiple lists

Howdy folks. Jeff here, back from my summer holiday in the Coromandel Peninsula in the North Island of New Zealand, where I’ve been staring at this for the last 21 days:
DDOE_Identifying duplicates between lists_Opoutere

For the next 344 I’ll be staring at this:
DDOE_Identifying duplicates between lists_Excel
God, it’s good to be home.

A while back I answered this thread for someone wanting to identify any duplicate values found between 4 separate lists.

The way I understood the question, if something appears in each of the four lists, the Op wanted to know about it. If an item just appeared in 3 lists but not all 4, then they didn’t want it to be picked up. And the lists themselves might have duplicates within each list.

Say we’ve got these 4 lists:
DDOE_Identifying duplicates between lists_Names

We can’t simply use Conditional Formatting, because that will include duplicate names that don’t appear in each and every column, such as ‘Mike’:
DDOE_Identifying duplicates between lists_Wrong

Rather, we only want names that appear in every column:
DDOE_Identifying duplicates between lists_Right

I wrote a routine that handled any number of lists, using two dictionaries and a bit of shuffling between them. And the routine allows users to select either a contiguous range if their lists are all in one block, or multiple non-contiguous ranges if they aren’t.

  1. The user gets prompted for the range where they want the identified duplicates to appear:
    DDOE_Identifying duplicates between lists_Select Output Range
  2.  

  3. Then they get prompted to select the first list. The items within that list get added to Dic_A. (If they select more than one columns, the following steps get executed automatically).
    DDOE_Identifying duplicates between lists_Select First Range
  4.  

  5. Next they get prompted to select the 2nd list, at which point the code attempts 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. At the end of this, we clear Dic_A. Notice that any reference to selecting a contiguous range has been dropped from the InputBox:
    DDOE_Identifying duplicates between lists_Select 2nd range
  6.  

  7. When they select the 3rd list, then it attempts to add each new item to Dic_B, and if an error occurs, then we know it’s a duplicate between lists, and so we add it to Dic_A. At the end of this, we clear Dic_B. We carry on in this manner until the user pushes Cancel (and notice now that the InputBox message tells them to push cancel when they’re done):
    DDOE_Identifying duplicates between lists_Select 3rd range
  8.  

Pretty simple: just one input box, an intentional infinite loop, and two dictionaries that take turns holding the current list of dictionaries. Hours of fun.

Only problem is, I had forgotten to account for the fact that there might be duplicates within a list. The old code would have misinterpreted these duplicates as between-list duplicates, rather than within-list duplicates. The Op is probably completely unaware, and probably regularly bets the entire future of his country’s economy based on my bad code. Oops.

I’ve subsequently added another step where a 3rd dictionary is used to dedup the items in the list currently being processed. Here’s the revised code. My favorite line is the Do Until “Hell” = “Freezes Over” one.


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

A date with PivotItems

Howdy, folks. Jeff here again. I’ve been sharpening up some code to manually filter a PivotField based on an external list in a range outside the PivotTable. It works blazingly fast. Unless there’s dates as well as non-dates in my PivotField. In which case it errors out.

Try this:
Put “Pivot” in A1
Put =TODAY() in A2
Put =VALUE(TODAY()) in A3

Now make a PivotTable out of that data.

Pivot_DDOE

Now put this code into the VBE and step through it:

Sub WhatThe()

Dim pf As PivotField
Set pf = ActiveSheet.PivotTables(1).PivotFields(1)
With pf
.NumberFormat = "d/mm/yyyy"
.PivotItems(1).Visible = True
.PivotItems(2).Visible = True
.NumberFormat = "General"
.PivotItems(1).Visible = True
.PivotItems(2).Visible = True
End With
End Sub

If the same thing happens to you as happens to me, you will either be speaking aloud the title of this routine, or you will be speaking aloud this:
Unable to get the PivotItems property of the PivotField class.

Go type these in the immediate pane:

? .PivotItems(1).name
41588
? .PivotItems(1).visible
True
? .PivotItems(2).name
10/11/2013
? .PivotItems(2).visible
Error 2042

What the…?

Now try these:

? ActiveSheet.PivotTables(1).PivotFields(1).numberformat
General
ActiveSheet.PivotTables(1).PivotFields(1).numberformat = "d/mm/yyyy"
? .PivotItems(2).name
10/11/2013
? .PivotItems(2).visible
True

So it seems can’t do certain stuff to a PivotItem if that PivotItem is a date but your PivotField number format is set to General.

That’s weird.

Equally weird, try this:
Select the PivotTable, and record a macro as you change it’s number format back to General.

Sub WhatThe_Part2()
ActiveSheet.PivotTables(“PivotTable14”).PivotFields(“Pivot”).Name = “General”
End Sub

What the …? Change the PivotField Number Format, and you get a macro that tells you that you changed the PivotField name!

So what happens if you run that macro? Well, it changes the name of the PivotField:
PivotField_20131110

It does nothing to the number format.

Strangely enough, I found some info on this problem at one of my most revisited blogposts that I had somehow missed: Jon Peltier’s Referencing Pivot Table Ranges in VBA

Stranger still, the answer was by Jon Peltier back in 2009 in relation to a question asked by….wait for it…me. Don’t know how I missed that. Must have been sleeping.
So I’ve come across this problem before, found an answer, completely forgotten about it, and then wasted 2 days trying to work out what the problem was, purely so I could Google my own answered question.

I’m going to read through all 238 ( and counting) comments in that thread and see what else Jon has told me over the years I’ve been learning VBA.
There’s also something on this at stackoverflow

Jeff

–edit–
Jon’s method was to loop through the pivot items, and compare the pivot item caption to what he was looking for:


For Each pi In pt.PivotFields("Order Month/Year").PivotItems
If pi.Caption = Format(TheDate, "m/dd/yyyy") Then
' or If DateValue(pi.Caption) = TheDate Then
'' FOUND IT
End If
Next

But now I know it’s probably easier just to change the format of the PivotField.

—edit 30 May 2014 —
Prompted by Jerry Sullivan’s comment I found that this was only an issue for non-US regional settings, and that this issue is now fixed in Excel 2013. (Thank you, Microsoft. But why the heck didn’t you tell me you’d fixed it?)

According to IronyAaron in the comments at this thread:

When VBA recognizes the dates in the pivot cache, it reads the US version after parsing although the item is read as a locally formatted string. This therefore causes VBA to fail when recognizing Date variables.

Bummer! So write some code that filters PivotItems, and you might find that non-US users have issues, unless they change their regional settings in Windows to US beforehand. Good luck with that.

— edit over —

Excel isn’t fully cooked.

It’s still raw in the middle, a bit.

  • PivotTables are great, but why can’t I filter one based on an external range?
  • Shape Styles would be cool, if I could add my own styles.
  • Slicers are great, but why isn’t there an easy way to instantly get an overview of what Slicers are connected to what PivotTables, and at the same time use the same interface to effortlessly manage this and set up exclusions?
  • Charts are great, but why do I have to manually cut and paste them many times in order to make up the equivalent of a Small Multiple chart?

Fortunately, in most cases Excel is pretty programmable. If it doesn’t do something out of the box – or if using the built-in functionality is tedious – then given the requisite skills or the right Google search then you can almost always work around such bottlenecks fairly efficiently.

Unfortunately, Excel isn’t fully programmable no matter what skills you have. The Partial Text Search box that you can use to manually filter PivotFields on partial text pretty much instantly is awesome. But you can’t address it via VBA…it’s for humans only. Which means you’ve got to iterate through potentially large PivotItems collections s-l-o-w-l-y in maybe minutes in order to do something that users can do in seconds. (I won’t mention VBA support for PowerPivot as another example, because PowerPivot is still fairly new. Rough rule of thumb: Don’t complain about something until it’s been sitting around at least 5 years in an unfinished state. At least, that’s what I tell my wife).

I’ve got some great code to handle the Filtering Pivots and the Slicers things. And I can code up a cut and paste thing for Charts pretty easily. But that Partial Text Search box I can’t help you with. Maybe this will help get it on someone’s radar, but obviously including such ‘niceties’ in the in-box functionality isn’t trivial. Otherwise the dialog box for MSQuery (which I still use) would let me expand it. And the Name Manager would let me do the things that the better Name Manager will do. And so on.

So presumably these things are not trivial to enhance, or they would be enhanced already. But here’s the thing: by comparison, my code for filtering pivots or managing Slicers is trivial to roll out to users compared to the effort required to add this functionality natively.

So question: Why don’t MS supplement their great unfinished app by building and offering to users useful workarounds in one of the most agile-ready platforms there is…VBA? Why aren’t they monitoring forums and blogs for the best and brightest productivity enhancements, and buying the IP from content creators at a song, then offering it to users as add-ins that plug the gap until they get around to finishing Excel?

Regards,
Jeff Weir.
Cosmetic Surgeon.