Formulas? Pah!

Welcome back to Twice Daily Dose of Excel. Heck, these days we’re more regular than Julian Assange’s visits to the Ecuadorian Embassy!

Audrey has a table that looks something like this (if you’re American):

Table US

…or like this (if you live somewhere sensible, like in New Zealand and a good deal many other places besides):

Table English

She uses this to track when she requested a piece of information from someone, and the date she received a response. I’m picking she’s NSA, and is asking Julian – who is actually a quadruple agent – whether he needs more sun lamps. Stranger things have happened, recently.

Anyways, she’d like a formula to find the oldest/latest request date out of all responses received in a particular month.

She could array enter something like this, which will do the job without any need for helper columns:

=MAX($A$2:$A$20*(DATE(YEAR($B$2:$B$20),MONTH($B$2:$B$20),1)=DATE(YEAR($B2),MONTH($B2),1)))

…which to an Excel Pro with a lifetime of formulas under their belt would look like this:

=NOT(RocketScience)

…but to anyone else:

="Αυτό θα μπορούσε κάλλιστα να είναι γραμμένο στην ελληνική γλώσσα"

You could debate whether there’s a right formula to use in a situation like this. In fact there’s some great debate on that original blogpost as to whether one proposed solution is awesome, potentially obfuscating, or incomprehensibly mutant. So with this in mind, is there a right formula to use in this case? Depends on who’s trying to comprehend what’s happening here in 6 months time. Perhaps yourself, with six more months of grey-matter dieback under your belt. Or hat, rather. Is there a right non-formula approach to Audrey’s problem? You betcha:

Just create a PivotTable out of that sucker:

Blank PivotTable

…drag the ‘Date Requested’ field to the Rows pane and the ‘Date Received’ to the Values pane:

PivotTable

…launch the Value Field Settings dialog for the Date Requested field:

Launch Value Field Settings

…change the name of the Date Received field to something meaningful, and change Sum to Max:

Value Field Settings Dialog

…plus click on that Number Format button while you’re there so you can change the format to Date:

Number Format

…then select any cell in the Date Received column and click Group Selection from the PivotTable Tools > Analyze contextual tab, and group by Months and Years:

Group Selection

…and exhale:

Pivot

No, waithold that breath…we forgot to change the name of that ‘Years’ column that just appeared – as well as the ‘Date Received’ column that now holds Months only – to something more suitable:

Pivot finished

Now exhale.

Here’s the genius…it even works in American:

Pivot finished american

and it works on trickier problems, like the original one at that post:

Original Problem

 
¿Fórmulas? No nos hacen falta fórmulas apestosas!

Centennial Weekend Birthdays

On this episode of the BBC’s More or Less podcast, they discussed big, round birthdays that fall on a weekend. A listener said that she had to wait until her 60th birthday for it to fall on a weekend. The guy who figured out how unlucky she was tested every birthday from January 1, 1900. Since he picked that date, I assume he used Excel, but he never said.

They did include the caveat “as an adult” so that leaves off the 10th birthday. Here’s how I did the math.

I started with 1/1/1900 is cell A2 and used the formula

=A2+1

copied down to today. Then in B1:J1, I entered the values 20-100. The formula in B2 is

=WEEKDAY(DATE(YEAR($A2)+B$1,MONTH($A2),DAY($A2)),2)>=6

I added the value in row 1 to the year to make the centennial birthday and fed that into the WEEKDAY function. WEEKDAY returns 1 through 7 representing the day of the week. I used ‘2’ for the second argument so that Monday is 1 and Saturday is 6. Then I return TRUE or FALSE depending on whether the weekday is greater than or equal to 6.

Column K finds the minimum age that has a TRUE under it

=MIN(IF(B2:J2,$B$1:$J$1,""))

That’s an array formula, so I entered it with Ctrl+Shift+Enter.

Next, I repeated 20-100 in column N. These formulas complete the table

    O3        =COUNTIF($K$2:$K$41832,N3)
    P3        =O3/SUM($O$3:$O$11)
    Q3        =Q2+P3

As if that wasn’t enough, I wanted to make a single formula that could accept a date and return the earliest major birthday that was on a weekend.

=MIN(IF(WEEKDAY(DATE(YEAR(O16)+{20,30,40,50,60},MONTH(O16),DAY(O16)),2)<6,"",{20,30,40,50,60}))

That’s also an array formula, so you know what to do. I celebrated my 30th birthday on a weekend.

Dynamic Vertical Line on a ScatterPlot

GMF comments:

I use XY charts for schedules and I like to have a vertical line showing today’s date. I do this so frequently I have a named range for each of the X and Y values. To get the current date to show up as 2 similar X values the best I could come up with is:

=(ROW(INDIRECT(“1:2″))/ROW(INDIRECT(“1:2″)))*TODAY()

There must be a better way, but I can’t just put ={TODAY(),TODAY()} as a value and I’m curious why.

Until somebody smart like Charles Williams jumps in with a better explanation, the reason you can’t put individual functions into an array is that you can’t. I know, it sucks. I’d like to be able to do that too.

Edit: Colin Legg beat Charles to it:

When you use { } within a formula they are delimiters for an array constant. The formula parser won’t let you embed functions or references within an array constant because, by definition, the elements wouldn’t be constant anymore.

That said, you can get there indirectly:
=TODAY()*{1,1}
={41854,41854}

Sure Jeff, but I want to be able to put different functions in each array position.

Not a problem…with a bit of cleverness, you can do the equivalent of this:
={MIN(SomeRange),Max(SomeRange)}

…like this:
=MIN(SomeRange)*{1,0}+MAX(SomeRange)*{0,1}

…which says to Excel:

  • Populate a 2-element array with the minimum of SomeRange, but multilpy the first element by 1 and the second element by 0, in order to clear the minimum from that second element.
  • Populate a 2-element array with the maximum of SomeRange, but multilpy the first element by 0 and the second element by 1, in order to clear the maximum from that first element.
  • Add them together, leaving just the minimum in the first, and the maximum in the second.

 
 

So how does this tie in with what GMF wants to do, i.e. put a vertical line in an XY chart to show the current date?
 
Chart

Well, because this is an XY chart, you only need two coordinates to draw that date line line: the point at the bottom, and the point at the top.

So to get the X values we want – today’s date, we define a name called Today:
=TODAY()*{1,1}
And for the Y values – the Min and Max values across both ‘Values’ series – we define a name called MinMax:
=MIN(SomeRange)*{1,0}+MAX(SomeRange)*{0,1}

And then we can add a new series called Today to our chart:
 
SelectDataSource

…with the X and Y coordinates of that series pointing at the appropriate name:
 
EditSeries

Of course, you don’t actually need a Named Range to do this… you can simply have some helper cells in the actual worksheet that calculate the Min and Max values of the entire block of data, and point your Today series at that:
 
Chart - non array2

Here’s a sample file with both approaches: Todays Date on ScatterPlot

Maybe this stuff is all included in Dick and Mike’s book 101 Ready-To-Use Excel Formulas. I don’t know…I’m still waiting for my free advance copy in the post.

Well, that’s all folks. Hopefully this post moved those lines on the chart closer together rather than pushing them apart.

Listing Calling Procedures

I have this awesome machine with 64-bit Office sitting under my desk. I don’t use it to code because MZ-Tools doesn’t work on 64-bit Office and I need that (and a few other things) to be productive. I only use a few features from MZ-Tools, so I think I’ll just write them in VBA. I took my first stab at the Procedure Callers feature.

Public Sub ListProcedureCallers()
   
    Dim vbProj As VBProject
    Dim vbModule As VBIDE.CodeModule
    Dim vbComp As VBIDE.VBComponent
    Dim i As Long
    Dim lActiveLine As Long
    Dim sProc As String
       
    'get the name of the current procedure
    Application.VBE.ActiveCodePane.GetSelection lActiveLine, 0, 0, 0
    sProc = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(lActiveLine, vbext_pk_Proc)
   
    'only look in the active project
    Set vbProj = Application.VBE.ActiveVBProject
   
    'loop through the code modules
    For Each vbComp In vbProj.VBComponents
        Set vbModule = vbComp.CodeModule
       
        'print the procedure for any line that contains the name of the active procedure
        If vbModule.CountOfLines > 0 Then
            For i = vbModule.CountOfDeclarationLines To vbModule.CountOfLines
                If InStr(1, vbModule.Lines(i, 1), sProc) > 0 And vbModule.ProcOfLine(i, vbext_pk_Proc) <> sProc Then
                    Debug.Print vbComp.Name, vbModule.ProcOfLine(i, vbext_pk_Proc), vbModule.Lines(i, 1), i
                End If
            Next i
        End If
    Next vbComp
   
End Sub

I just wanted to get something down and not be too worried about how well it works. This procedure just prints to the Immediate Window rather than a fancy userform that let’s you go directly to one of the procedures.

One of the things I don’t like about MZ-Tools is that it searches for callers in all open projects. I can see that value in that, I just personally have never needed it. And for procedures with common names, it shows a crap ton of stuff. I made my procedure only search the current project.

One of my property procedures in one of my class modules is named Active. When I looked for its callers, I got every procedure that uses ActiveWorkbook or ActiveSheet. My code does not discriminate – if the name of the procedure appears in the line of code, it’s a hit.

How do I avoid that? For the Active property, all I have to do is look for a space after the word Active and I should be good to go. Except for comments, perhaps. That’s fine for a property with no arguments, but if it has arguments or is a method with arguments, there won’t be a space after it but a parenthesis. Can I search for either a space or a paren? Seems like it, but I’ll have to think it through.

Another thing I don’t like about MZ-Tools is that it doesn’t care what class module you’re in when you look for calling procedures. Every one of my Collection Classes has an Add method. When I search for procedure callers for Add, I get every call to every Add method in every class.

That’s a little tougher proposition. I could be very opinionated, as I am, by looking for clsPlural.Add rather than just Add. I always name my class instance variables clsXXX. That would work for me, but wouldn’t be very general purpose. While I’m a well-known selfish prick, I do still care about you, dear reader. Even if I were so inclined, I’d have to still look for With blocks. I can’t just look for clsPlural.Add, I have to also look for .Add, then I have to search up the lines of code for a With before I hit an End With, then I have to determine the variable… My goodness that sounds like a lot of work. This is probably why MZ-Tools doesn’t care which Add method I’m looking for – it’s just not worth it.

Here’s some things I’d like to do:

  • Find actual callers, not just the procedure name
  • Omit finds in comments
  • When I’m in a class, only find properties/methods from that class
  • When I’m on a Property Get, don’t return Property Let assignment statements
  • Go to the first caller automatically, but still list the rest somewhere
  • Other stuff I haven’t thought of

What say you?

Quickly changing or deleting Named Ranges Redux

I know a good thing when I see it. Dick’s use of the word Redux in yesterday’s post for one. Dick’s nifty CreateDynamicNames() sub for another. Put them together, and you’ve got a winning combination. Or at least, 5 minutes of distraction between whatever the heck it is you’re supposed to be doing instead of reading this post. Work, most likely.

Yesterday I posted a barely fleshed out bit of code that took some of the tedium out of maintaining Named Ranges. Mostly it saved you scrolling through a potentially overwhelming list of Names in order to find the one you want to maintain or zap:

NameManager1

 
Today, we’re going to turn yesterday’s rather underwhelming interface:

Please select new range

 
…into this slightly less underwhelming interface:
Right Click

Our first step is to put some code in the Personal Macro Workbook to add those additional right-click items to the right-click menus – aka context menus – that we’re likely to use in relation to the grid. Three of these menus spring to mind:

  1. The “List Range PopUp” CommandBar that you see if you right click over a Table.
  2. The “PivotTable Context Menu” CommandBar that you see if you right click over a PivotTable.
  3. The “Cell” CommandBar that you’re likely to see if you right click over a range that’s not a Table or a PivotTable.

There’s probably more. Let me know in the comments if you can think of others relevant to this post.

Name your poison

Here’s the code I use to add the shortcuts:

Sub AddShortcuts()
    Dim cbr As CommandBar
    Dim i As Long
 
    DeleteShortcuts
 
    For i = 1 To 3
        Select Case i
        Case 1: Set cbr = Application.CommandBars("Cell")
        Case 2: Set cbr = Application.CommandBars("List Range PopUp")
        Case 3: Set cbr = Application.CommandBars("PivotTable Context Menu")
        End Select
       
 
       'Add Stand-alone buttons for Duplicate/Delete resource subs
       With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
           .Caption = Chr(Asc("&")) + "Rename Selected Named Range"
           .Tag = "RenameName"
           .OnAction = "RenameName"
           .Style = msoButtonIconAndCaption
           .Picture = Application.CommandBars.GetImageMso("NameDefine", 16, 16)
           .BeginGroup = True
       End With
   
       With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
           .Caption = Chr(Asc("&")) + "Point Selected Named Range Elsewhere"
           .Tag = "RepointName"
           .OnAction = "RepointName"
           .Style = msoButtonIconAndCaption
           .Picture = Application.CommandBars.GetImageMso("ArrangeByAppointmentStart", 16, 16)
       End With
     
       With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
           .Caption = Chr(Asc("&")) + "Zap the Selected Named Range"
           .Tag = "DeleteName"
           .OnAction = "DeleteName"
           .Style = msoButtonIconAndCaption
           .Picture = Application.CommandBars.GetImageMso("DeleteTable", 16, 16)
       End With
     
        With cbr.Controls.Add(Type:=msoControlButton, Temporary:=True)
           .Caption = Chr(Asc("&")) + "Lightning fast Dynamic Ranges!"
           .Tag = "DynamicRanges"
           .OnAction = "CreateDynamicNames"
           .Style = msoButtonIconAndCaption
           .Picture = Application.CommandBars.GetImageMso("UMLEvents", 16, 16)
       End With
       
    Next
 
End Sub

Here’s the code I use to delete ‘em:

Sub DeleteShortcuts()
 
    Dim cbr As CommandBar
    Dim ctrl As CommandBarControl
    Dim i As Long
 
    For i = 1 To 3
        Select Case i
        Case 1: Set cbr = Application.CommandBars("Cell")
        Case 2: Set cbr = Application.CommandBars("List Range PopUp")
        Case 3: Set cbr = Application.CommandBars("PivotTable Context Menu")
        End Select
 
        ' Delete the custom controls with the Tag : My_Cell_Control_Tag.
        For Each ctrl In cbr.Controls
            Select Case ctrl.Tag
            Case "RenameName", "RepointName", "DeleteName", "DynamicRanges"
                ctrl.Delete
            End Select
        Next ctrl

    Next i
 
 
End Sub

That Chr(Asc(“&”)) + stuff in that first routine sets the accelerator keys, so that all you musophobes don’t have to obsessively wash your hands each time you use these. Instead, you can use the menu key:
Menu-Key

…and then hit the R, P, Z, or L keys accordingly.
CloseUp

I was going to try to spell something rude with these, but it was like playing Scrabble against Microsoft, who already took all the best letters. Cheats!

(Aside: There’s a good discussion over at Chandoo’s blog about the menu key, and what to do if some tight-wad manufacturer hasn’t put it on their machines.)

These shortcuts get added when Excel starts/closes courtesy of the Workbook_Open/Workbook_Close events in the ThisWorkbook module in my Personal Macro Workbook:

Private Sub Workbook_Open()
AddShortcuts
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteShortcuts
End Sub

So that sets the stage. Next, we need some actual routines to do something when we select from those right-click menus.

Hi. My name is…

(what?) My name is… (who?)
My name is… [scratches] Slim Shady

Here’s the main function: a routine that returns a delimited string containing the names of any names that reference your reference:

Function IdentifyNames(rng As Range) As String
 
'Identifies any Named Ranges that map directly to rng
Dim nm As Name
Dim strNames As String
 
For Each nm In ActiveWorkbook.Names
    On Error Resume Next
    If nm.RefersToRange.Address(External:=True) = rng.Address(External:=True) Then
        If Err.Number = 0 Then strNames = strNames & nm.Name & "|"
        End If
    On Error GoTo 0
Next
 
IdentifyNames = strNames
 
End Function

And here’s my three functions to Repoint, Rename, or completely ‘Reck those names:

Sub RepointName()
 
    Dim nm As Name
    Dim strNames As String
    Dim rngNew As Range
    Dim rngExisting As Range
    Dim lngNames As Long
    Dim strMessage As String
    Dim strMultipleNames As String
    Dim i As Long
   
    Set rngExisting = Selection
    strNames = IdentifyNames(rngExisting)
    lngNames = UBound(Split(strNames, "|"))
    If lngNames = -1 Then
        'There is no named range that matches. So let the user choose one.
        Application.Dialogs(xlDialogNameManager).Show
    Else:
        For i = 0 To lngNames - 1
            Set nm = ActiveWorkbook.Names(Split(strNames, "|")(i))
            If lngNames > 1 Then
                strMultipleNames = "I found " & lngNames & " Named Ranges that reference your selection, "
                strMultipleNames = strMultipleNames & "so we 'll go through them one by one."
                strMultipleNames = strMultipleNames & vbNewLine & vbNewLine
                strMultipleNames = strMultipleNames & "Name " & i + 1 & " of " & lngNames & ":"
                strMultipleNames = strMultipleNames & vbNewLine & vbNewLine
            End If
            On Error Resume Next
            Set rngNew = Application.InputBox( _
                Title:="Please select new range", _
                Prompt:=strMultipleNames & "Select the range where you want """ & nm.Name & """ to point at.", _
                Default:=Selection.Address, _
                Type:=8)
            On Error GoTo 0
            If Not rngNew Is Nothing Then
                nm.RefersTo = "='" & ActiveSheet.Name & "'!" & rngNew.Address
                rngNew.Select
            End If
        Next i
    End If
       
End Sub
Sub RenameName()
 
Dim nm As Name
Dim strNames As String
Dim nmExists As Name
Dim strRefersTo As String
Dim strMultipleNames As String
Dim strNew As String
Dim rng As Range
Dim lngNames As Long
Dim i As Long
 
    Set rng = Selection
    strNames = IdentifyNames(rng)
    lngNames = UBound(Split(strNames, "|"))
    If lngNames = -1 Then
        'There is no named range that matches. So let the user choose one.
        Application.Dialogs(xlDialogNameManager).Show
    Else:
        For i = 0 To lngNames - 1
            Set nm = ActiveWorkbook.Names(Split(strNames, "|")(i))
            If lngNames > 1 Then
                strMultipleNames = "I found " & lngNames & " Named Ranges that reference your selection, "
                strMultipleNames = strMultipleNames & "so we 'll go through them one by one."
                strMultipleNames = strMultipleNames & vbNewLine & vbNewLine
                strMultipleNames = strMultipleNames & "Name " & i + 1 & " of " & lngNames & ":"
                strMultipleNames = strMultipleNames & vbNewLine
            End If
            On Error Resume Next
            strNew = Application.InputBox( _
                Title:="Please input the new name...", _
                Prompt:=strMultipleNames & "Please type the new name for """ & nm.Name & """.", _
                Default:=nm.Name, _
                Type:=2)
            If strNew = "False" Then Exit Sub
            If Not strNew = nm.Name Then
                strNew = Fix_Name(strNew)
                On Error Resume Next
                Set nmExists = ActiveWorkbook.Names(strNew)
                On Error GoTo 0
                If nmExists Is Nothing Then
                    nm.Name:=strNew
                Else:
                    MsgBox "That name already exists. Please choose another."
                    Set nmExists = Nothing
                End If
            End If
        Next
    End If
   
End Sub
Sub DeleteName()
 
Dim nm As Name
Dim strNames As String
Dim strMessage As String
Dim iResponse As Integer
Dim rngExisting As Range
Dim lngNames As Long
Dim i As Long
 
strNames = IdentifyNames(Selection)
lngNames = UBound(Split(strNames, "|"))
Select Case lngNames
    Case -1:
        'There is no named range that matches. So let the user choose one.
        Application.Dialogs(xlDialogNameManager).Show
    Case 1: ActiveWorkbook.Names(Split(strNames, "|")(0)).Delete
    Case Else:
        For i = 0 To lngNames - 1
            Set nm = ActiveWorkbook.Names(Split(strNames, "|")(i))
                strMessage = "I found " & lngNames & " Named Ranges that reference your selection, "
                strMessage = strMessage & "so we 'll go through them one by one."
                strMessage = strMessage & vbNewLine & vbNewLine
                strMessage = strMessage & "Name " & i + 1 & " of " & lngNames & ":"
                strMessage = strMessage & vbNewLine
                strMessage = strMessage & "Do you want to delete the Named Range """ & nm.Name & """?"
                iResponse = MsgBox( _
                            Title:="Multiple Names Found", _
                            Prompt:=strMessage, _
                            Buttons:=vbYesNoCancel + vbQuestion)
                Select Case iResponse
                    Case vbYes: nm.Delete
                    Case vbNo: 'do nothing
                    Case vbCancel: Exit Sub
                End Select
            Next i
    End Select
End Sub

These subs are all fairly intelligent in that they handle the case where just one Named Range resolves to the selection:
One Name

…as well as multiple Named Ranges resolving to the selected range:
rename

So given this code is supposed to do something to Named Ranges that point at the current selection, what happens if someone runs it on a range that no names point at? Glad I asked. It brings up a the inbuilt ‘Name Manager’, in case the user does actually want to do something with a name, but forgot to select the range it resolves to:
Name Manager again

Lastly, here’s Dick’s code that I shamelessly lifted, that lets you create lots of Dynamic Named Ranges from your current selection, in response to a question from GMF. (Now that is a strange name!)

Sub CreateDynamicNames()
   
    Dim rCell As Range
    Dim sCol As String
    Dim sPrefix As String
    Dim strPrompt As String
   
    If TypeName(Selection) = "Range" Then
        strPrompt = "I'll use the headings in the top row to name each range." & vbNewLine & vbNewLine
        strPrompt = strPrompt & "OPTIONAL:  You can enter a prefix below if you want, and I'll use it to prefix each Named Range with." & vbNewLine & vbNewLine
        strPrompt = strPrompt & "Otherwise just push OK, and I'll use the headings as is."
       
        sPrefix = Application.InputBox( _
                Title:="Please input a prefix if you want one...", _
                Prompt:=strPrompt, _
               Type:=2)
            If sPrefix = "False" Then Exit Sub
           
        For Each rCell In Selection.Rows(1).Cells
            If rCell.Value <> "" Then ActiveWorkbook.Names.Add Fix_Name(sPrefix & rCell.Value), "='" & rCell.Parent.Name & "'!" & rCell.Offset(1).Address & ":INDEX('" & rCell.Parent.Name & "'!" & rCell.EntireColumn.Address & ",COUNTA('" & rCell.Parent.Name & "'!" & rCell.EntireColumn.Address & "))"
        Next rCell
    End If
   
End Sub

This code is a real timesaver. Simply select a range that looks like this:
Dynamic Before

…select this from the Right Click menu:
Lightning Fast

…add a prefix if you want:

Some Prefix

…and next time you open NameManager, you’ll see those names are all good to go:

Dynamic After

Pure magic, Dick.

And lastly, here’s Craig Hatmaker’s function I use to clean names:

Public Function Fix_Name(sName As String) As String
 
'   Description:Conforms a string so it can be used as a name
 
'   Parameters: sName       String to be conformed
 
'   Example:    sColumnName = Fix_Name("1st deposit %")
 
'     Date   Ini Modification
'   11/02/10 CWH Initial Programming
'   11/20/10 CWH Used "Like" operator
 
    'If Not DebugMode Then On Error GoTo ErrHandler
    Fix_Name = sName
   
    Dim i As Integer
           
   'Substitute special invalid characters w/standard abbreviations
   sName = Replace(sName, "#", "_NUM")
    sName = Replace(sName, "$", "_AMT")
    sName = Replace(sName, "%", "_PCT")
    sName = Replace(sName, "-", ".")
    sName = Replace(sName, ",", "-")
    sName = Replace(sName, " ", "_")
   
   'Get rid of all other illegal characters
    i = 1
    Do While i <= Len(sName)
        If Not Mid(sName, i, 1) Like "[A-Z,a-z,0-9,.,_,\]" Then _
            sName = Left(sName, i - 1) & Right(sName, Len(sName) - i)
        i = i + 1
    Loop
   
   'First Character cannot be numeric & result cannot look like cell ref.
    If IsNumeric(Left(sName, 1)) Or sName Like "[A-Z]#" Then _
        sName = "_" & sName
 
    Fix_Name = sName
 
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Fix_Name - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
 
End Function

All this is in the attached file, along with some names for you to try it out on. Adjust Named Ranges_20140801

Name-dropper!

In terms of how the above code works, you can find a very good introduction on Ron de Bruin’s site, and you’ll likely learn a lot by poking around Doug Glancy’s site and in the VBA in his MenuRighter and FaceIdViewer addins.

Listing Conditional Formatting Redux

Back in the day, I posted some code to list conditional formatting. It didn’t contemplate having multiple conditional formats for the same range. Because who would ever do that right? Of course that happens all the time and was very short-sighted of me. I aim to atone.

I used a Collection object because Collection objects can’t have two Keys that are the same. It’s a good way to get a unique list out of a list that contains duplicates. I used the range to which the FormatCondition applies as the key (and that was my downfall). My thought was this: I’m checking each cell individually and a FormatCondition that spans two cell would be counted twice. A FormatCondition that applied to L9:M9 would be counted for L9 and M9. By using the address as my unique key, it would only be counted once – the first time for L9 and it would error out and not be counted for M9.

Except you can have two FormatConditions that apply to L9:M9 and only the first would every be counted. I needed a way to identify what was a duplicate and what was a legitimate second FormatCondition. I cleverly devised (read stole from Bob Phillips) that I would add the count to the end of the address. But I got lucky in that it failed for my particular setup. The way my FormatConditions were created, they weren’t in the same order for all the cells. So even though an FC was the same for a later cell, it was the 3rd FC instead of the 2nd, and that made it seem unique.

I set out to find a better way to uniquely identify FCs, and here it is

Public Function CFSignature(ByRef cf As Variant) As String
   
    Dim aReturn(1 To 3) As String
   
    aReturn(1) = cf.AppliesTo.Address
    aReturn(2) = FCTypeFromIndex(cf.Type)
    On Error Resume Next
        aReturn(3) = cf.Formula1
       
    CFSignature = Join(aReturn, vbNullString)
   
End Function

It’s still no guarantee of uniqueness, but if you have two FCs with the same range, the same type, and the same formula, well, you gets what you deserves. Now I can use the ‘signature’ instead of the address.

Public Sub ShowConditionalFormatting()
   
    Dim cf As Variant
    Dim rCell As Range
    Dim colFormats As Collection
    Dim i As Long
    Dim wsOutput As Worksheet
    Dim aOutput() As Variant
   
    Set colFormats = New Collection
   
    For Each rCell In Sheet1.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
        For i = 1 To rCell.FormatConditions.Count
            With rCell.FormatConditions
                On Error Resume Next
                    colFormats.Add .Item(i), CFSignature(.Item(i))
                On Error GoTo 0
            End With
        Next i
    Next rCell
       
    ReDim aOutput(1 To colFormats.Count + 1, 1 To 5)
   
    Set wsOutput = Workbooks.Add.Worksheets(1)
    aOutput(1, 1) = "Type": aOutput(1, 2) = "Range"
    aOutput(1, 3) = "StopIfTrue": aOutput(1, 4) = "Formual1"
    aOutput(1, 5) = "Formual2"
   
    For i = 1 To colFormats.Count
        Set cf = colFormats.Item(i)
           
        aOutput(i + 1, 1) = FCTypeFromIndex(cf.Type)
        aOutput(i + 1, 2) = cf.AppliesTo.Address
        aOutput(i + 1, 3) = cf.StopIfTrue
        On Error Resume Next
            aOutput(i + 1, 4) = "'" & cf.Formula1
            aOutput(i + 1, 5) = "'" & cf.Formula2
        On Error GoTo 0
    Next i
   
    wsOutput.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
    wsOutput.UsedRange.EntireColumn.AutoFit
   
End Sub

And in case you forgot, here’s how I got the type.

Function FCTypeFromIndex(lIndex As Long) As String
   
    Select Case lIndex
        Case 12: FCTypeFromIndex = "Above Average"
        Case 10: FCTypeFromIndex = "Blanks"
        Case 1: FCTypeFromIndex = "Cell Value"
        Case 3: FCTypeFromIndex = "Color Scale"
        Case 4: FCTypeFromIndex = "DataBar"
        Case 16: FCTypeFromIndex = "Errors"
        Case 2: FCTypeFromIndex = "Expression"
        Case 6: FCTypeFromIndex = "Icon Sets"
        Case 14: FCTypeFromIndex = "No Blanks"
        Case 17: FCTypeFromIndex = "No Errors"
        Case 9: FCTypeFromIndex = "Text"
        Case 11: FCTypeFromIndex = "Time Period"
        Case 5: FCTypeFromIndex = "Top 10?"
        Case 8: FCTypeFromIndex = "Unique Values"
        Case Else: FCTypeFromIndex = "Unknown"
    End Select
       
End Function

Now this

gets you this

Quickly changing or deleting Named Ranges

One thing that’s always irked me about working with Named Ranges is that while you may have selected the cells that a particular Named Range points at and can even see that name in the Name Box…

NameBox1

…you can’t do anything actually useful to it – such as changing where it points too or deleting it – without first firing up the NameManager, and then rummaging through the haystack for the particular name that you want to amend …

NameManager2

…and then clicking through another damned dialog box…

Edit Name

…or two…
NameManager Refers To

…or three…
Confirm

…purely to change where it points at. Deleting it is nearly as bad, too.

Wouldn’t it be cool if instead of all that rodent-work, you simply pushed some arbitrary keyboard short-cut of your choice, which then told Excel “Hey Excel, I want to resize or delete the Named Range that corresponds to my current selection. Can you do that for me? Can you? Huh?”

And wouldn’t it be cool if Excel then said…

Please select new range

Cool, indeed. File this baby in your Personal Macro Workbook, and trigger it with a keyboard short-cut of your choice:

Sub AmendSelectedName()

Dim nm As Name
Dim strRefersTo As String
Dim rngNew As Range
Dim rngExisting As Range

Set rngExisting = Selection
For Each nm In ActiveWorkbook.Names
    strRefersTo = nm.RefersTo
    If Replace(Replace(strRefersTo, "=", ""), "'", "") = ActiveSheet.Name & "!" & rngExisting.Address Then
        On Error Resume Next
        Set rngNew = Application.InputBox( _
            Title:="Please select new range", _
            Prompt:="Select new range for """ & nm.Name & """ or push Cancel to delete it.", _
            Default:=Selection.Address, _
            Type:=8)
        On Error GoTo 0
        If Not rngNew Is Nothing Then
            nm.RefersTo = "='" & ActiveSheet.Name & "'!" & rngNew.Address
            rngNew.Select
        Else: nm.Delete
        End If
    End If
Next

End Sub

Broken Arrow

Dick et al tell me that my over-use of the arrow anti-patten is broken…

Broken Arrow

…to the point that my Ifs are well out of sight of my EndIfs. So much so, that I’ve got into the habit of appending my closing IF statements with an apostrophe and then adding the text of the matching opening IF statement, so I can keep track of exactly where each block ends, like so:

                                End If 'If Not bIdentified Then
                            End If 'If lngFields = 1 Then
                        End If 'If Not bIdentified Then
                    End If 'If InStr(.Summary, "|") = 0

Dick tells me that if things have got that bad, the code should be refactored. After making some lame excuses, I thought I’d take these comments on board, and see whether a remake made for ultimately more satisfying viewing.

With this particular code, I’m trying to find out what PivotField (if any) got filtered. I have three separate tests – each of slightly increasing complexity. The first test doesn’t require much, and picks up what PivotField got filtered in probably 80% of cases. The 2nd test requires a little bit more processing, and probably picks up what PivotField got filtered in half the remaining cases. The last test requires something quite invasive, but will correctly identify those last remaining cases that the other tests missed.

Those three tests can easily be split into three separate functions, so that someone following along finds the whole code easier to conceptualize.

So here’s the first function, which checks the structure of the PivotTable after a change against a record of the structure that we previously saved to the PivotTable.Summary field:

Function PivotChange_LayoutComparison(pt As PivotTable, ByRef strVisibleItems As String) As String

    Dim pf As PivotField
    Dim pi As PivotItem
    Dim i As Long
   

    For Each pf In pt.PivotFields
        With pf
            Select Case .Orientation
            Case xlRowField, xlColumnField
                strVisibleItems = strVisibleItems & .Name & "|" & .VisibleItems.Count & "||"
            Case xlPageField
                'pf.VisibleItems.Count doesn't work on PageFields
                'So for PageFields we’ll record what that PageField’s filter currently displays.
                strVisibleItems = strVisibleItems & .Name & "|" & .LabelRange.Offset(, 1).Value & "|" & .EnableMultiplePageItems & "||"
            End Select
        End With
    Next pf
   
    With pt
        If .Summary <> strVisibleItems Then
            For i = 0 To UBound(Split(.Summary, "||"))
                If Split(.Summary, "||")(i) <> Split(strVisibleItems, "||")(i) Then
                    PivotChange_LayoutComparison = Split(Split(.Summary, "||")(i), "|")(0)
                    Exit For
                End If
            Next i
        End If
    End With

End Function

And here’s the second function, that checks all the visible fields to see if *just one of them alone* has neither .AllItemsVisible = True nor .EnableMultiplePageItems = false. If so, then by process of elimination, this field must be the one that triggered the change, as changes to any of the others would have been identified in the previous function.

Function PivotChange_EliminationCheck(pt As PivotTable, ByRef strPossibles As String) As String


    'Check all the visible fields to see if *just one of them alone* has
    ' neither .AllItemsVisible = True nor .EnableMultiplePageItems = false.
    ' If that's the case, then by process of elimination, this field
    ' must be the one that triggered the change, as changes to any of the
    ' others would have been identified in the code earlier.
   
    Dim pf As PivotField
    Dim pi As PivotItem
    Dim lngFields As Long
   
    lngFields = 0
    On Error Resume Next ' Need this to handle DataFields and 'Values' field
    For Each pf In pt.PivotFields
        With pf
            If .Orientation > 0 Then 'It's not hidden or a DataField
                If .EnableMultiplePageItems And Not .AllItemsVisible Then
                    If Err.Number = 0 Then
                        'It *might* be this field
                        lngFields = lngFields + 1
                        strPossibles = strPossibles & .Name & ";"
                    Else: Err.Clear
                    End If
                End If
            End If
        End With
    Next
    On Error GoTo 0


    If lngFields = 1 Then PivotChange_EliminationCheck = Left(strPossibles, Len(strPossibles) - 1)

End Function

And lastly, here’s the function that records the .VisibleItems for the PivotTable that just changed, then programatically hits the Undo button so it can play spot-the-difference between what things looked like after the user made that change:

Function PivotChange_UndoCheck(pt As PivotTable, strPossibles) As String

    Dim lngFields As Long
    Dim i As Long
    Dim dicFields As Object 'This holds a list of all visible pivotfields
    Dim dicVisible As Object 'This contains a list of all visible PivotItems for a pf
    Dim varKey As Variant
    Dim ctr As CommandBarControl
    Dim pf As PivotField
    Dim pi As PivotItem
    Dim bidentified As Boolean
    Dim lngVisibleItems As Long
   
       
    Application.EnableEvents = False

    'Create master dictionary
    Set dicFields = CreateObject("Scripting.Dictionary")

    'Cycle through all pivotfields, excluding totals
    For i = 0 To UBound(Split(strPossibles, ";")) - 1
        'Create dicVisible: a dictionary for each visible PivotField that contain visible PivotItems
        Set dicVisible = CreateObject("Scripting.Dictionary")
        Set pf = pt.PivotFields(Split(strPossibles, ";")(i))
        With pf
        If .Orientation <> xlPageField Then
            For Each pi In .VisibleItems
                With pi
                    dicVisible.Add .Name, .Name
                End With
            Next pi
        Else:
            'Unfortunately the .visibleitems collection isn't available for PageFields
            ' e.g. SomePageField.VisibleItems.Count always returns 1
            ' So we'll have  to iterate through the pagefield and test the .visible status
            ' so we can then record just the visible items (which is quite slow)
             For Each pi In .PivotItems
                With pi
                    If .Visible Then
                        dicVisible.Add .Name, .Name
                    End If
                End With
            Next pi
        End If 'If .Orientation = xlPageField Then
        'Write dicVisible to the dicFields master dictionary
        dicFields.Add .Name, dicVisible
        End With
    Next i

    Application.Undo

    For Each varKey In dicFields.keys
        Set pf = pt.PivotFields(varKey)
        Set dicVisible = dicFields.Item(varKey)

        'Test whether any of the items that were previously hidden are now visible
            If pf.Orientation <> xlPageField Then
                For Each pi In pf.VisibleItems
                    With pi
                        If Not dicVisible.exists(.Name) Then
                            PivotChange_UndoCheck = pf.Name
                            bidentified = True
                            Exit For
                        End If
                    End With
                Next
            Else 'pf.Orientation = xlPageField
                lngVisibleItems = dicVisible.Count
                i = 0
                For Each pi In pf.PivotItems
                    With pi
                        If .Visible Then
                            If Not dicVisible.exists(.Name) Then
                                PivotChange_UndoCheck = pf.Name
                                bidentified = True
                                Exit For
                            Else: i = i + 1 'this is explained below.
                            End If
                        End If
                    End With
                Next

                ' For non-PageFields, we know that the number of .VisibleItems hasn't changed.
                ' But we *don't* know that about Pagefields, and an increase in the amount of
                ' .VisibleItems won't be picked up by our Dictionary approach.
                ' So we'll check if the overall number of visible items changed
                If Not bidentified And i > lngVisibleItems Then
                    PivotChange_UndoCheck = pf.Name
                    Exit For
                End If
            End If
            If bidentified Then Exit For
        Next

    'Resore the original settings
    With Application
        .CommandBars(14).FindControl(ID:=129).Execute 'Standard Commandbar, Redo command
        .EnableEvents = True
    End With
   

End Function

Lastly, here’s how I call them all:

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
   
    Dim strLastUndoStackItem As String
    Dim strPossibles As String
    Dim strVisibleItems As String
    Dim strPivotChange As String


    On Error Resume Next 'in case the undo stack has been wiped or doesn't exist
    strLastUndoStackItem = Application.CommandBars(14).FindControl(ID:=128).List(1) 'Standard Commandbar, undo stack
    On Error GoTo 0

    If strLastUndoStackItem = "Filter" Or strLastUndoStackItem = "Slicer Operation" Then
        strPivotChange = PivotChange_LayoutComparison(Target, strVisibleItems)
        If strPivotChange = "" Then strPivotChange = PivotChange_EliminationCheck(Target, strPossibles)
        If strPivotChange = "" Then strPivotChange = PivotChange_UndoCheck(Target, strPossibles)
        Target.Summary = strVisibleItems
        If strPivotChange <> "" Then MsgBox strPivotChange
    Else:
        MsgBox strLastUndoStackItem
    End If
       
End Sub

 
Yep, I think this remake is much, much better looking than the original:
Broken Arrow Broken Arrow Remake

Here’s the sample file: PivotChange_20140802

Updating the For Next AutoHotkey in the VBE

Last month I posted about some AHK scripts I was starting to use to make the VBE a little less gross every day. There were some awesome comments. I took Hubisan’s comment and ran with it through a few iterations. First, let’s go to the video.

I use a program called CamStudio. For some reason it’s blurry for the first 30 seconds. I really need to get Techsmith’s Camtasia. But it gets the point across for now.

I’m seriously digging the AHK stuff. Here’s the script:

:*:for ::
;when you type for{space}, replace it with caps so you know you're in AHK mode
SendInput FOR{Space}
;wait for the next word and store it in counter
Input, counter,I V T10,{Space}{Escape}
;finish with ESC and you thwart AHK
;but finish with a space and more stuff happens
if (ErrorLevel = "EndKey:Space")
    {
    ;if the next word is each, it's a for each loop
    if (counter = "each")
        {
        ;wait for the next word and store it in eachctr
        Input, eachctr, I V T10,{Space}{Escape}
        if (ErrorLevel = "EndKey:Space")
            {
            ;Once you know eachctr, fill in the Next line and go back up to the For line
            SendInput +{HOME}{DELETE}{Enter}Next %eachctr%{Up}For Each %eachctr%{Space}
            }
        }
    ;if the next word is one of these, you're opening a text file
    else if (counter = "Append" or counter = "Binary" or counter = "Input" or counter = "Output" or counter = "Random")
        {
        ;get the next word - it really should only be 'As'
        Input, askeyword, I V T10,{Space}{Escape}
        if (ErrorLevel = "EndKey:Space")
            {
            if (askeyword = "As")
                {
                ;the word after 'As' is the file number
                Input, filenum, I V T10,{Enter}{Escape}
                if (ErrorLevel = "EndKey:Enter")
                    {
                    ;complete the close statement, because I always forget that.
                    SendInput {Enter}Close{Space}
                    ;you got to send this part raw because there may be a # in there and that's special
                    SendRaw %filenum%
                    SendInput {Up}
                    }
                }
            }
        }
    else
        {
        ;and finally if it's not all that special stuff, it's just a for next
        SendInput +{HOME}{DELETE}{Enter}Next %counter%{Up}For %counter%{Space}
        }
    }
Return

I put in comments so hopefully you can follow along. All I’ve done is copy Hubisan’s code, so if I took something nice and made it total crap it’s because I don’t know what I’m doing.

Bob Phillips made a good point in the last post about how he doesn’t prefer the automation. The automation gets in the way sometimes and typing the code slows things down so you can use your brain a little more. Good points, I thought, but I still like the automation. I can relate to the point that it gets in the way sometimes. In a previous iteration, I would type For i and it would put Next i, plus a blank line, plus a tab. That means when I’m done with the For statement, I have to arrow down. I don’t want to arrow down. I want to hit enter, then tab. So I made the automation fit the way I want to work and now I’m very happy with it.

What caused that PivotTableUpdate? Episode IV

Pivot Wars 3 Small

So if you’ve been merrily following along, then you’ll know that we’ve got a function that picks up which PivotField just got filtered in a PivotTable, with a couple of exceptions:

  • If users change the PivotFilter list, but leave the same count of things visible, or
  • If any stinky PageField filters read ‘Multiple Items’ both before and after the change.

We’re about to add something more to our previous function to handle those cases.

With a few very minor exceptions, the majority of our previous function remains unchanged, and looks like so:

Function PivotChange_GetFilterName(pt As PivotTable) As String

    Dim strLastUndoStackItem As String
    Dim pf As PivotField
    Dim pi As PivotItem
    Dim i As Long
    Dim lngVisibleItems As Long
    Dim lngFields As Long
    Dim strVisibleItems As String
    Dim bIdentified As Boolean
    Dim strElimination As String
    Dim bElimination As Boolean
    Dim dicFields As Object 'This holds a list of all visible pivotfields
    Dim dicVisible As Object 'This contains a list of all visible PivotItems for a pf
    Dim varKey As Variant
   
    Application.EnableEvents = False
   
    On Error Resume Next 'in case the undo stack has been wiped or doesn't exist
    strLastUndoStackItem = Application.CommandBars("Standard").FindControl(ID: = 128).Control.List(1)
    On Error GoTo 0
   
    If strLastUndoStackItem <> "" Then
        For i = 1 To pt.VisibleFields.Count
            Set pf = pt.VisibleFields(i)
            With pf
                If .Orientation <> xlDataField And .Name <> "Values" Then
                    If .Orientation <> xlPageField Then
                        strVisibleItems = strVisibleItems & .Name & "|" & .VisibleItems.Count & "||"
                    Else
                        'pf.VisibleItems.Count doesn't work on PageFields
                        'So for PageFields we’ll record what that PageField’s filter currently displays.
                        strVisibleItems = strVisibleItems & .Name & "|" & .LabelRange.Offset(, 1).Value & "|" & .EnableMultiplePageItems & "||"
                    End If
                End If
            End With
        Next i
        Select Case strLastUndoStackItem
            Case "Filter", "Select Page Field Item", "Slicer Operation"
                With pt
                    If InStr(.Summary, "|") > 0 Then 'the Summary field contains previously recorded info about pivot layout etc
                        If .Summary <> strVisibleItems Then
                            For i = 0 To UBound(Split(.Summary, "||"))
                                If Split(.Summary, "||")(i) <> Split(strVisibleItems, "||")(i) Then
                                    PivotChange_GetFilterName = "PivotFilter changed: " & Split(Split(.Summary, "||")(i), "|")(0)
                                    bIdentified = True
                                    Exit For
                                End If
                            Next i
                        End If 'If .Summary <> strVisibleItems Then
                       
                        If Not bIdentified Then
                        'Check all the visible fields to see if *just one of them alone* has
                        ' neither .AllItemsVisible = True nor .EnableMultiplePageItems = false.
                        ' If that's the case, then by process of elimination, this field
                        ' must be the one that triggered the change, as changes to any of the
                        ' others would have been identified in the code earlier.
                            lngFields = 0
                            For Each pf In pt.VisibleFields
                                With pf
                                    If .Orientation <> xlDataField And .Name <> "Values" Then
                                        If .AllItemsVisible = True Then
                                            'it's not this field
                                            bElimination = True
                                        ElseIf .Orientation = xlPageField And .EnableMultiplePageItems = False Then
                                            ' it's not this field either
                                            bElimination = True
                                        Else
                                            'It *might* be this field
                                            lngFields = lngFields + 1
                                            strElimination = strElimination & .Name & ";"
                                        End If 'If .AllItemsVisible = True The
                                    End If 'If .Orientation <> xlDataField And .Name <> "Values" Then
                                End With
                            Next pf
                           
                            If lngFields = 1 Then
                                PivotChange_GetFilterName = "PivotFilter changed: " & Left(strElimination, Len(strElimination) - 1)
                                bIdentified = True
                            Else

But now, to track down those exceptions, we’re going to have to work some magic. Or as I put it in the code:

    '                           =================================
    '                            We will have to use *The Force*
    '                           =================================

For each visible PivotField, we’re going to compare the list of what is visible now to what was visible before. Bear in mind that we don’t know in advance what PivotTable the user is going to tamper with. Given this, you may be asking yourself:

C3PO 2

You’re dead right, Golden Rod. And that will require us to either keep a duplicate of every PivotTable in the workbook, or to extract every single pivotitem in the entire workbook to a Dictionary or Array that we would have to continually update.

Unless we use the Force. Yes, let’s use the Force. After all, it is all around us.

With the help of The Force:

  1. We’re only going to record the settings for the PivotTable that just changed
  2. Then we’re going to programatically hit the Undo button
  3. Then we’re going to play spot-the-difference between what things looked like after the user made that change:
    After2

    …and what it looked like before they made that change:
    Before2

  4. Then we’re going to restore things back to the way the user wanted them:
    After2

 
To do this, we’re going to employ a Dictionary.
Of Dictionaries.
Like so:

                                If Not bIdentified Then
                                ' The If statement above is purely there to catch the possibility that
                                ' we failed to find the filter in the above code because it's the first
                                ' time we've run the code, meaning nothing was previously stored in pt.summary
                               
                                    'Create master dictionary
                                    Set dicFields = CreateObject("Scripting.Dictionary")
                                   
                                    'Cycle through all visible pivotfields, excluding totals
                                    For i = 0 To lngFields - 1
                                        'Create dicVisible: a dictionary for each PivotField that contain visible PivotItems
                                        Set dicVisible = CreateObject("Scripting.Dictionary")
                                        Set pf = pt.PivotFields(Split(strElimination, ";")(i))
                                        With pf
                                        If .Orientation <> xlPageField Then
                                            For Each pi In .VisibleItems
                                                With pi
                                                    dicVisible.Add .Name, .Name
                                                End With
                                            Next pi
                                        Else:
                                            'Unfortunately the .visibleitems collection isn't available for PageFields
                                            ' e.g. SomePageField.VisibleItems.Count always returns 1
                                            ' So we'll have  to iterate through the pagefield and test the .visible status
                                            ' so we can then record just the visible items (which is quite slow)
                                             For Each pi In .PivotItems
                                                With pi
                                                    If .Visible Then
                                                        dicVisible.Add .Name, .Name
                                                    End If
                                                End With
                                            Next pi
                                        End If 'If .Orientation = xlPageField Then
                                        'Write dicVisible to the dicFields master dictionary
                                        dicFields.Add .Name, dicVisible
                                        End With
                                    Next i

Great, so we know what’s visible now. But what about before?
Well, in keeping with the Star Wars theme, anyone fancy a prequel?

                                    Application.Undo

And now we’ll check how the old compares to the new:

                                    For Each varKey In dicFields.keys
                                        Set pf = pt.PivotFields(varKey)
                                        Set dicVisible = dicFields.Item(varKey)
                                       
                                        'Test whether any of the items that were previously hidden are now visible
                                            If pf.Orientation <> xlPageField Then
                                                For Each pi In pf.VisibleItems
                                                    With pi
                                                        If Not dicVisible.exists(.Name) Then
                                                            bIdentified = True
                                                            PivotChange_GetFilterName = "PivotFilter changed: " & pf.Name
                                                            Exit For
                                                        End If
                                                    End With
                                                Next
                                            Else 'pf.Orientation = xlPageField
                                                lngVisibleItems = dicVisible.Count
                                                i = 0
                                                For Each pi In pf.PivotItems
                                                    With pi
                                                        If .Visible Then
                                                            If Not dicVisible.exists(.Name) Then
                                                                bIdentified = True
                                                                PivotChange_GetFilterName = "PivotFilter changed: " & pf.Name
                                                                Exit For
                                                            Else: i = i + 1 'this is explained below.
                                                            End If 'If Not dicVisible.exists(.Name) Then
                                                        End If 'If .Visible Then
                                                    End With
                                                Next
                                               
                                                ' For non-PageFields, we know that the number of .VisibleItems hasn't changed.
                                                ' But we *don't* know that about Pagefields, and an increase in the amount of
                                                ' .VisibleItems won't be picked up by our Dictionary approach.
                                                ' So we'll check if the overall number of visible items changed
                                                If Not bIdentified And i > lngVisibleItems Then
                                                    bIdentified = True
                                                    PivotChange_GetFilterName = "PivotFilter changed: " & pf.Name
                                                    Exit For
                                                End If
                                            End If 'If pf.Orientation <> xlPageField Then
                                            If bIdentified = True Then Exit For
                                        Next

Great, we’ve found it. Now it’s time for operation Application.Redo!

WAIT! There is no Application.Redo method!

junk

 
Aw, screw it…let’s use that Force stuff again:

                                    'Resore the original settings
                                    Application.CommandBars("Standard").FindControl(ID:=129).Execute

…and then set the Hyperdrive for home:

                                End If 'If Not bIdentified Then
                            End If 'If lngFields = 1 Then
                        End If 'If Not bIdentified Then
                    End If 'If InStr(.Summary, "|") = 0 Then
                End With
            Case Else: PivotChange_GetFilterName = strLastUndoStackItem
        End Select
    End If 'If strLastUndoStackItem <> ""
    pt.Summary = strVisibleItems
    Application.EnableEvents = True
   
    'Cleanup
    Set dicFields = Nothing
    Set dicVisible = Nothing

End Function

 
 
Stormtrooper: Let me see your sample file.

Obi-Wan: [with a small wave of his hand] You don’t need to see his sample file.

Stormtrooper: We don’t need to see his sample file.

Obi-Wan: These aren’t the sample files you’re looking for.

Stormtrooper: These aren’t the sample files we’re looking for.

Obi-Wan: He can go about his pivoting.

Stormtrooper: You can go about your pivoting.

Obi-Wan: Move along.

Stormtrooper: Move along… move along.

 
 
 
Okay, okay…here’s the sample file.

Can you stop remotely squeezing my throat now, Darth?
PivotChange_20140802

 
Test Pattern

Update

I have re-factored the code in the sample file as per the post at Broken Arrow.