Loop through Field on Power Pivot Table

[jeran042]

I have a bit of script that I need some assistance with.
The purpose of the script is to iterate over a Power Pivot table and for each item in the pivot, filter and export to a new file.

However when I get to the line:

'pf.CurrentPage = pi.Value
        pf.CurrentPageName = pi.Value

With pf.CurrentPage = pi.Value I get an error: runtime error 1004 unable to get the pivotfields property of the pivottable class
With pf.CurrentPageName = pi.Value I get error: runtime error 1004 application-defined or object-defined error.

I have posted the code below and sectioned off the part that is throwing the error:
Full disclosure I did post this question in another form back on 6/29 but did not get any suggestions or guidance. And I running short on time.
Any help would be greatly appreciated,

Option Explicit
'EXCEL MACRO

Sub Salary_Reports()



'Confirm that the user wants to complete action
    If MsgBox("This action will Create a file for Each Department, " & vbNewLine & _
                    "Do you want to continue? ", vbCritical + vbYesNo, "WARNING") = vbYes Then


    Dim pt As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    Dim iCost As Long
    
    Dim sFileLocation As String
    Dim StartTime As Double
    Dim MinutesElapsed As String
    
    
    'Error handling
        On Error GoTo Error_Handler
        
  'Remember time when macro starts
  'PURPOSE: Determine how many minutes it took for code to completely run
  'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
        StartTime = Timer
 
    'Turn on Optimize_VBA
        Optimize_VBA True
        
    'Clear pivot table cache
        'Workbook_Open
            
    
    'Set where you want the reports to be saved
        'sFileLocation = "X:\"
    
    'Test Location
        sFileLocation = "X:\"
    
  
    'The 1 pivot table that we are going to iterate over
        'Set pt = Sheets("export_template").PivotTables("PivotTable4")
        'Set pt = Sheet2.PivotTables.items("Salary_Pivot")
        Set pt = ActiveSheet.PivotTables.Item("Salary_Pivot")
        
    'Range of departments to iterate through on each of the pivot tables
        'Set rngList = Sheet1.Range("dept_listing")
    
            'Loop thorugh the active pvot (as this is a Data Model) Pivot Tables and pull filed names
        
                For Each pf In pt.PivotFields
                    Debug.Print pf.Name
                Next


    'The criteria field within the pivit table
        Set pf = pt.PivotFields("[ADP YTD Listing].[COST_DEPT].[COST_DEPT]")
      
            'List all the itmes in pt.PivotFields("[ADP YTD Listing].[COST_DEPT].[COST_DEPT]")
                For Each pi In pf.PivotItems
                    Debug.Print pi.Value
                Next pi
    
    
        Debug.Print ActiveSheet.Name
'----------------------------------------------------------------------
'
'BEGIN FOR EACH LOOP
'
'----------------------------------------------------------------------
    For Each pi In pf.PivotItems
    
    'Extract Cost Center from the name
        'iCost = Trim(Left(pi.Caption, InStr(pi.Caption, " ") - 1))
        'Debug.Print iCost
    
    'Confirm we are stepping through the range (department) list correctly
        Debug.Print pi.Value


'!!!THIS IS THE LINE(S) THAT ARE THROWING THE ERROR!!!
    
'Filter Pivot on "Template" tab by the department stored in "pi.Caption"
        'pf.CurrentPage = pi.Value
        pf.CurrentPageName = pi.Value

'!!!THIS IS THE LINE(S) THAT ARE THROWING THE ERROR!!!

'###########################################################################################################################
'FROM THIS POINT ON, WE ARE WORKING WITH THE INDIVIDUAL DEPARTMENTS WORKBOOK

   'Beginning of new file check point
    Debug.Print "Starting to work with the: " & pi.Caption & " File"

    'Create the new workbook and Save the workbook to file location
        Dim wb As Workbook
        Sheets(Array("Instructions", "Template")).Copy
        Set wb = ActiveWorkbook
            'MsgBox ActiveWorkbook.Name

    'This will suppress the alert dialog boxes
    'Save file and set it to be password protected
    'Debug.Print sFileLocation & pi.Caption & "_2021_Salary_Forecast" & ".xlsx"
    
        Application.DisplayAlerts = False
        wb.SaveAs sFileLocation & pi.Caption & "_2021_Salary_Forecast" & ".xlsx", , iCost & "*" & "knights"
        Application.DisplayAlerts = True

    'Starting clean up
        Debug.Print "Starting clean up on: " & pi.Caption & " File"
    
        With wb.Worksheets("Template")
            .Range("A:L").Copy
            .Range("M:W").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
            .Range("M:W").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            .Columns("A:L").EntireColumn.Delete
            .Rows("4:5").Delete
            .Range("A1").Select
        End With
    
        'Bring the focus back on the Contents worksheet
        wb.Worksheets("Instructions").Activate
        
        'Save and close workbook
        wb.Close SaveChanges:=True

'    'EXITING THE INDIVIDUAL DEPARTMENTS WORKBOOK

'###########################################################################################################################
  
    'Saved and moving to the next department
        Debug.Print "The Following workbook has been created and Saved: " & pi.Caption

        Next pi
    
    'Turn on Optimize_VBA
        Optimize_VBA False
    
    'Determine how many seconds code took to run
      MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
      
    'Notify user in seconds
      MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
      
    'Confirmation
        MsgBox "Success!  That's some good work ", vbInformation, "GREAT JOB"
        
    
'Exit if user clicks no
Else
        MsgBox "D'OH!      ", vbInformation, "CHECK YA LATER!"
End If

Exit Sub
    
'This is a work in process, not sure what errors I will need to handle yet
Error_Handler_Exit:
            Exit Sub

Error_Handler:
                    MsgBox "Error No. " & Err.Number & vbCrLf & "Description: " & Err.Description, vbExclamation, "Database Error"
                    Err.Clear
                    Resume Next
                    Resume Error_Handler_Exit
    
End Sub



Sub Optimize_VBA(isOn As Boolean)
' Make the macro run more efficiently

    Application.Calculation = xlAutomatic
    Application.EnableEvents = Not (isOn)
    Application.ScreenUpdating = Not (isOn)
    
End Sub



Private Sub Workbook_Open()
'Clear the cache of each pivot table in the workbook

    Dim xPt As PivotTable
    Dim xWs As Worksheet
    Dim xPc As PivotCache
    
    For Each xWs In ActiveWorkbook.Worksheets
        For Each xPt In xWs.PivotTables
            xPt.PivotCache.MissingItemsLimit = xlMissingItemsNone
        Next xPt
    Next xWs
    
    For Each xPc In ActiveWorkbook.PivotCaches
        On Error Resume Next
        xPc.Refresh
    Next xPc
    
End Sub

 

[jeran042]

I ended up solving this issue.
I adapted the code below to fit my needs:

I was able to find this code in another post. I have to give credit to @xlnitwit

Sub ChangeFilterInPivot()
    Dim i As Integer
    Dim pf As PivotField
    Dim items
    Dim sItem As String
    Dim parts
    Application.ScreenUpdating = False
    With ActiveSheet.PivotTables("Salary_Pivot")
        .PivotCache.Refresh
        With .PivotFields("[ADP YTD Listing].[COST_DEPT].[COST_DEPT]")
            .ClearAllFilters
            For i = 1 To .PivotItems.Count
                sItem = .PivotItems(i)
                .VisibleItemsList = Array(sItem)
                ' can't have square brackets in a file name
                parts = Split(sItem, "[")
                sItem = Replace$(parts(UBound(parts)), "]", "")
              
                ActiveWorkbook.SaveAs Filename:= _
                                      "X:\" & sItem & ".xlsm", _
                                      FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

                .ClearAllFilters
            Next i
        End With
    End With
End Sub