Help Modifying Existing Forum Code that Filters Pivot Tables

[Katterman]

Hello Everyone

I'm looking for some assistance in Modifying some existing code to filter a pivot table.
I've searched all over the board (and Google) and found many variations of code to do this
but have yet to tweak it to a point that works for me.

I'm using some code provided by Jerry Sullivan found HERE and it works on my pivot table except
for one thing. I'm using an Array to hold a number of dates and i need the code to select only the
dates in the array to be visible. The code as is will select the first and last dates in the array but will also
select ALL dates in between. It does not "ignore" and dates that are midding from the array between the first and last dates.

This is what i have and would like to tweak to use only the vales found in my Array.

Sub Pivot_Outage_Dates()


'http://www.mrexcel.com/forum/excel-questions/606328-change-pivot-page-filter-based-upon-two-cell-values-dates.html#post3007354


    Dim dtFrom As Date, dtTo As Date
    Dim pt As PivotTable
    Dim ERow1 As Date
     
    With Sheets("STATS")
    ERow1 = Columns("O").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Value
    End With
    
    With Sheets("NAT_Pivot")
        Set pt = .PivotTables("PivotTable6")
        dtFrom = Sheets("STATS").Range("O10")
        dtTo = ERow1
    End With
    
    Call Filter_PivotField_by_Date_Range( _
        pt.PivotFields("Date Created"), dtFrom, dtTo)
End Sub


Public Function Filter_PivotField_by_Date_Range(pvtField As PivotField, _
        dtFrom As Date, dtTo As Date)
        Dim bTemp As Boolean, i As Long
        Dim dtTemp As Date, sItem1 As String
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual


    With pvtField
        .Parent.ManualUpdate = True
        For i = 1 To .PivotItems.Count
            dtTemp = .PivotItems(i)
            bTemp = (dtTemp >= dtFrom) And _
                (dtTemp <= dtTo)
            If bTemp Then
                sItem1 = .PivotItems(i)
                Exit For
            End If
        Next i
'        If sItem1 = "" Then
'            MsgBox "No items are within the specified dates."
'            Exit Function
'        End If




        If .Orientation = xlPageField Then .EnableMultiplePageItems = True
        .PivotItems(sItem1).Visible = True
        For i = 1 To .PivotItems.Count
            dtTemp = .PivotItems(i)
            If .PivotItems(i).Visible <> _
                ((dtTemp >= dtFrom) And (dtTemp <= dtTo)) Then
                .PivotItems(i).Visible = Not .PivotItems(i).Visible
            End If
        Next i
    End With
    
    pvtField.Parent.ManualUpdate = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Function

This code:

    With Sheets("STATS")
    ERow1 = Columns("O").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Value
    End With

Would need to be replaced with my Array Code:

    With Worksheets("STATS")
    Arr1 = .Range("O10", .Range("O" & Rows.Count).End(xlUp)).Value
    End With

And as far as the Array goes, it comes from a Dynamic range that populates with dates in a range of either
7 fields (Weekly) or 31 Fields (Monthly). It populates the array based on the Non Empty fields in the range.

Well, Hopefully that made sense and someone can assist.
Like mentioned before, I've looked around a lot and tried many pieces of code
before reaching out for help

Thank you all for reading and to those who reply.

Scott

 

[Jerry Sullivan]

Hi Scott, It takes a bit more back and forth to solve something when I can't replicate the problem myself - but I'm confident we'll find a modification that works for you.

Your date field is in the PageField (Report Filters) area so it's not surprising that on your first run there were no listings of "Added to dictionary..."

You'll need to add similar code to handle PageFields. Try modifying this part....

      '--put all currently visible items into dictionary
      Dim sNote As String
      For Each pvi In pvf.PivotItems
         sNote = "Testing item: " & pvi.Caption & _
            "> char: " & Len(pvi.Caption)
         If pvi.RecordCount Then
            sNote = sNote & " records found..."
            If pvi.Visible = True Then
               sNote = sNote & " Visible=True. Will add to dictionary."
               sItem = dctCurrentlyVisible.Item(pvi.Caption)
            Else
               sNote = sNote & " Visible=False. Will not add to dictionary."
            End If
         Else
            sNote = sNote & " NO records found. Not added to dictionary."
         End If
         '--only display if not a date format
         If InStr(sNote, "/") = 0 Then Debug.Print sNote
      Next pvi

Are there any blanks in your actual data source? One possibility is that you have your PivotTable Options set to "retain items deleted from the data source". If there are not blanks in your data source, but that PivotItem has been retained, that could explain the difference in our results.

One other test you could try is to move the Date field to the Rows area of the PivotTable to see if the code can clear the checkbox when it is there.

One oddity about the 2nd test results you reported - you shouldn't have had any "Added to dictionary" messages unless the pivotfield "Date Created" was in the Rowfields or Columnfields area of the Pivot.

 

[Katterman]

Hello Jerry

See below the Quotes

Hi Scott, It takes a bit more back and forth to solve something when I can't replicate the problem myself - but I'm confident we'll find a modification that works for you.

Your date field is in the PageField (Report Filters) area so it's not surprising that on your first run there were no listings of "Added to dictionary..."

You'll need to add similar code to handle PageFields. Try modifying this part....

      '--put all currently visible items into dictionary
      Dim sNote As String
      For Each pvi In pvf.PivotItems
         sNote = "Testing item: " & pvi.Caption & _
            "> char: " & Len(pvi.Caption)
         If pvi.RecordCount Then
            sNote = sNote & " records found..."
            If pvi.Visible = True Then
               sNote = sNote & " Visible=True. Will add to dictionary."
               sItem = dctCurrentlyVisible.Item(pvi.Caption)
            Else
               sNote = sNote & " Visible=False. Will not add to dictionary."
            End If
         Else
            sNote = sNote & " NO records found. Not added to dictionary."
         End If
         '--only display if not a date format
         If InStr(sNote, "/") = 0 Then Debug.Print sNote
      Next pvi

Are there any blanks in your actual data source? One possibility is that you have your PivotTable Options set to "retain items deleted from the data source". If there are not blanks in your data source, but that PivotItem has been retained, that could explain the difference in our results.

There are No Blanks in the Source Data and that option is Not enabled.
When using the attached code:

I tested this with "ALL" including (Blanks) initially checked,
and 1/4/2016, 1/5/2016 & 1/7/2016 in the range to be read into Arr1.
The resulting output was....


Testing item: (blank)> char: 7 NO records found. Not added to dictionary.
1/4/2016: No Change
1/5/2016: No Change
1/6/2016:
1/7/2016: No Change
1/8/2016:
1/9/2016:
1/10/2016:

** (Blank) was still selected **

I Again tested this with 1/5/2016 & (Blanks) initially checked,
and 1/5/2016 in the range to be read into Arr1.
The resulting output was..
NOTHING In Immediate Window
and

I Again tested this with 1/5/2016, 1/6/2016 & (Blanks) initially checked,
and 1/5/2016 & 1/6/2016 in the range to be read into Arr1.
The resulting output was..
Testing item: (blank)> char: 7 NO records found. Not added to dictionary.
1/5/2016: No Change
1/6/2016: No Change

and

(Blanks) still selected.

One other test you could try is to move the Date field to the Rows area of the PivotTable to see if the code can clear the checkbox when it is there.

This method works exactly the way i want. The "(Blank)" is unchecked.

I tested this with 1/4/2016 and (blank) initially checked, and 1/4/2016 in the range to be read into Arr1.
The resulting output was....
1/4/2016: No Change
(blank):


I Again tested this with "ALL" (Including (Blank)) initially checked,
and 1/5/2016 , 1/5/2016 & 1/9/2016 in the range to be read into Arr1.
The resulting output was....
1/4/2016:
1/5/2016: No Change
1/6/2016: No Change
1/7/2016:
1/8/2016:
1/9/2016: No Change
1/10/2016:
(blank):

So it would appear this works as needed.
Now, does this help to figure out why this doesn't work as expected when the DAte in only in
the "Filter" area as it was originally?

One oddity about the 2nd test results you reported - you shouldn't have had any "Added to dictionary" messages unless the pivotfield "Date Created" was in the Rowfields or Columnfields area of the Pivot.

Unsure as well on this one.


Hopefully all the above will help further narrow down or produce alternate code

Thanks again for all your help

Scott

 

[Jerry Sullivan]

Scott, If you don't have any blank items in the source data, then it makes sense that the checkbox was not unchecked.

In the past, I've gotten errors when trying to read or change the Visible property of pivotItems that have been retained in the list, but have no items in the data source.
To avoid that, I typically add this step which skips over items that have been deleted from the data source...

 If pvi.RecordCount Then
       ' ...code to run only if records exist.

It appears that if this test is eliminated the code doesn't throw an error when it sets the Visible property of a pivotItem that has no records in the data source- at least with my Excel 2013.

So try modifying this part of the code to read....

      '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         If pvi.Visible = True Then _
            sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi

 

[Katterman]

Hello Jerry

Ok, Between all the code tweaks etc, something has gone wrong and now getting errors.
May be time for some code cleanup.

Here's what I have

Private Sub FilterPivotField(ByVal pvf As PivotField, _   ByVal vItems As Variant)


'--filters pivotfield to show only items in vItems list


'--approach is to compare the visibleitems property to vItems.
'    items in both lists: No change
'    items in visibleitems property only: hide
'    items in vItems only: unhide if pivotitem exists


 Dim bHasMatches As Boolean
 Dim dctCurrentlyVisible As Object
 Dim dctToShow As Object
 Dim lNdx As Long
 Dim sItem As String
 Dim pvi As PivotItem
 Dim vKey As Variant
 Dim sNote As String
 
 Set dctCurrentlyVisible = CreateObject("Scripting.Dictionary")
 Set dctToShow = CreateObject("Scripting.Dictionary")
 dctCurrentlyVisible.CompareMode = 1 'TextCompare
 dctToShow.CompareMode = 1
 
 '--validate vlist is array
 If Not IsArray(vItems) Then
   sItem = vItems
   ReDim vItems(1, 1)
   vItems(1, 1) = sItem
 End If
 
 '--do processes specific to orientation of pivotfield
 Select Case pvf.Orientation
   Case xlPageField
      '--Optional: if one item only- use CurrentPage
      If UBound(vItems) = 1 Then
         pvf.ClearAllFilters
         On Error Resume Next
         pvf.CurrentPage = vItems(1, 1)
         If Err.Number <> 0 Then _
            MsgBox "No matching items found - Report Filter cleared."
         On Error GoTo 0
         GoTo ExitProc
      End If
      
      If pvf.EnableMultiplePageItems = False Then
         pvf.EnableMultiplePageItems = True
      End If
 
       '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         sNote = "Testing item: " & pvi.Caption & _
            "> char: " & Len(pvi.Caption)
         If pvi.RecordCount Then
            sNote = sNote & " records found..."
            If pvi.Visible = True Then
               sNote = sNote & " Visible=True. Will add to dictionary."
               sItem = dctCurrentlyVisible.Item(pvi.Caption)
            Else
               sNote = sNote & " Visible=False. Will not add to dictionary."
            End If
         Else
            sNote = sNote & " NO records found. Not added to dictionary."
         End If
         '--only display if not a date format
         If InStr(sNote, "/") = 0 Then Debug.Print sNote
      Next pvi
 
      '--put all currently visible items into dictionary
'      For Each pvi In pvf.PivotItems
'        If pvi.RecordCount Then
'            If pvi.Visible = True Then _
'               sItem = dctCurrentlyVisible.Item(pvi.Caption)
          '''  Debug.Print "Added to dictionary: " & _
          '''  pvi.Caption & "> characters: " & Len(pvi.Caption)
'         End If
'      Next pvi
 
   Case xlRowField, xlColumnField
       '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         If pvi.Visible = True Then _
            sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi
       
       
'      For Each pvi In pvf.VisibleItems
'         sItem = dctCurrentlyVisible.Item(pvi.Caption)
'      Next pvi
   Case Else
      MsgBox "Incorrect PivotField Orientation. Exiting macro."
      GoTo ExitProc
 End Select
 
 '--step through list of items to be visible
 pvf.Parent.ManualUpdate = True
 For lNdx = LBound(vItems) To UBound(vItems)
   sItem = vItems(lNdx, 1)
   '--if already visible, mark item
   If dctCurrentlyVisible.Exists(sItem) Then
      dctCurrentlyVisible(sItem) = "No Change"
      bHasMatches = True
   Else
      '--show if exists, handle if doesn't exist
      On Error Resume Next
      pvf.PivotItems(sItem).Visible = True
      If Err.Number = 0 Then bHasMatches = True
      On Error GoTo 0
   End If
 Next lNdx
 
 If bHasMatches Then
   '--at least one item will be visible after filtering
   With dctCurrentlyVisible
      For Each vKey In .Keys
       ''' Debug.Print vKey & ": " & .Item(vKey)
         If .Item(vKey) <> "No Change" Then
            '--hide items visible at start but not in vItems
            pvf.PivotItems(vKey).Visible = False
         End If
      Next vKey
   End With
 Else
   MsgBox "No matching items found"
 End If
 pvf.Parent.ManualUpdate = False


ExitProc:
End Sub

Sorry but in the process of commenting old and new in and out. something got skewd

Scott

Scott, If you don't have any blank items in the source data, then it makes sense that the checkbox was not unchecked.

In the past, I've gotten errors when trying to read or change the Visible property of pivotItems that have been retained in the list, but have no items in the data source.
To avoid that, I typically add this step which skips over items that have been deleted from the data source...

 If pvi.RecordCount Then
       ' ...code to run only if records exist.

It appears that if this test is eliminated the code doesn't throw an error when it sets the Visible property of a pivotItem that has no records in the data source- at least with my Excel 2013.

So try modifying this part of the code to read....

      '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         If pvi.Visible = True Then _
            sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi

 

[Jerry Sullivan]

No problem Scott, Here's the modified version without any of the Debug.Print statements.

Private Sub FilterPivotField(ByVal pvf As PivotField, _
   ByVal vItems As Variant)

'--filters pivotfield to show only items in vItems list

'--approach is to compare the visibleitems property to vItems.
'    items in both lists: No change
'    items in visibleitems property only: hide
'    items in vItems only: unhide if pivotitem exists

 Dim bHasMatches As Boolean
 Dim dctCurrentlyVisible As Object
 Dim dctToShow As Object
 Dim lNdx As Long
 Dim sItem As String
 Dim pvi As PivotItem
 Dim vKey As Variant
 
 Set dctCurrentlyVisible = CreateObject("Scripting.Dictionary")
 Set dctToShow = CreateObject("Scripting.Dictionary")
 dctCurrentlyVisible.CompareMode = 1 'TextCompare
 dctToShow.CompareMode = 1
 
 '--validate vlist is array
 If Not IsArray(vItems) Then
   sItem = vItems
   ReDim vItems(1, 1)
   vItems(1, 1) = sItem
 End If
 
 '--do processes specific to orientation of pivotfield
 Select Case pvf.Orientation
   Case xlPageField
      '--Optional: if one item only- use CurrentPage
      If UBound(vItems) = 1 Then
         pvf.ClearAllFilters
         On Error Resume Next
         pvf.CurrentPage = vItems(1, 1)
         If Err.Number <> 0 Then _
            MsgBox "No matching items found - Report Filter cleared."
         On Error GoTo 0
         GoTo ExitProc
      End If
      
      If pvf.EnableMultiplePageItems = False Then
         pvf.EnableMultiplePageItems = True
      End If
 
      '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         If pvi.Visible = True Then _
            sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi
 
   Case xlRowField, xlColumnField
       '--put all currently visible items into dictionary
      For Each pvi In pvf.VisibleItems
         sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi
   Case Else
      MsgBox "Incorrect PivotField Orientation. Exiting macro."
      GoTo ExitProc
 End Select
 
 '--step through list of items to be visible
 pvf.Parent.ManualUpdate = True
 For lNdx = LBound(vItems) To UBound(vItems)
   sItem = vItems(lNdx, 1)
   '--if already visible, mark item
   If dctCurrentlyVisible.Exists(sItem) Then
      dctCurrentlyVisible(sItem) = "No Change"
      bHasMatches = True
   Else
      '--show if exists, handle if doesn't exist
      On Error Resume Next
      pvf.PivotItems(sItem).Visible = True
      If Err.Number = 0 Then bHasMatches = True
      On Error GoTo 0
   End If
 Next lNdx
 
 If bHasMatches Then
   '--at least one item will be visible after filtering
   With dctCurrentlyVisible
      For Each vKey In .Keys
         If .Item(vKey) <> "No Change" Then
            '--hide items visible at start but not in vItems
            pvf.PivotItems(vKey).Visible = False
         End If
      Next vKey
   End With
 Else
   MsgBox "No matching items found"
 End If
 pvf.Parent.ManualUpdate = False

ExitProc:
End Sub

 

[Katterman]

Thanks Jerry.

Still getting an error: Run-time Error '13': Type Mismatch

When it gets to and Highlights " If pvi.Visible = True Then "
in this section:

      '--put all currently visible items into dictionary
      For Each pvi In pvf.PivotItems
         If pvi.Visible = True Then _
            sItem = dctCurrentlyVisible.Item(pvi.Caption)
      Next pvi

I Just have 2 dates in my Arr1 and the Pivot Table is set to the default of "All" selected ( As if just created and before filtering)

Sorry this is dragging out a bit longer than Either of us expected.

Scott

No problem Scott, Here's the modified version without any of the Debug.Print statements.

 

[Jerry Sullivan]

Scott, I think you're encountering the error that led me to skip over PivotItems that don't have any items in the data source. Unfortunately, with my current version of Excel (2013), I don't seem to be able to replicate that scenario. I'm able to have retained items that aren't in the data source appear in the RowFields. When I try to do the same with the PageFields (Report Filters), those items don't appear on the filter checklist. What version of Excel are you using?

Am I correct in understanding that when using the original code in Post #5, you get the correct values displayed in the Pivot Report, and that the checking of (blank) will have no impact on the values in the report?

 

[Katterman]

Hello Jerry, see Below

What version of Excel are you using?

I'm using Microsoft Excel 2013 (15.0.4787.1002) 32 Bit Part Of MS office 365 ProPlus

Am I correct in understanding that when using the original code in Post #5, you get the correct values displayed in the Pivot Report, and that the checking of (blank) will have no impact on the values in the report?

Yes that is correct so i guess the best option at this point is to use that code.
I don't want to cause any more "Wheel Spinning" if the end result is more of a
minor detail and not affecting the final result of the data. Do you agree?

Scott

 

[Jerry Sullivan]

Well I guess it isn't a version issue.

I'm interested to find a solution and would like to keep working with you toward that if you don't mind.

Can you provide an example workbook (with any sensitive data changed) that shows (blank) in listed in the Report Filters area even though it isn't in the data source?

You can upload that to a sharing site like box.com and provide a link, or else send me a PM and we'll exchange email addresses.

 

[Katterman]

Hello Jerry

Ok, Some weird stuff now.

I Created a New WB from the 2 sheets required for you to test with.
I Ran the code and "ALL" works fine now. No Errors and Blanks NOT selected.
So, went back to my Original sheet and it works there as well.
This is on my Work PC that I VPN into.

The Strange part is, i have the same Excel at home I Where i sometimes work from
and that is where the exact copy of the sheet is failing with the error described above,
Recopied working sheet from Work PC to Home PC and still errors on Home Machine with
what works on Work PC.

Now i'm really Stumped but as far as this Work Data and Code is concerned, this seems to be OK.

I'll send you a PM with the link to my Test Data sheet that works on Work PC and Not at home with Same versions of Excel.

Since the code works where needed, i'd understand if you wan to consider this resolved.

Scott

Well I guess it isn't a version issue.

I'm interested to find a solution and would like to keep working with you toward that if you don't mind.

Can you provide an example workbook (with any sensitive data changed) that shows (blank) in listed in the Report Filters area even though it isn't in the data source?

You can upload that to a sharing site like box.com and provide a link, or else send me a PM and we'll exchange email addresses.