asked on

Pivot Table filter VBA

Can you please help?

I have a workbook that contains dynamic number of sheets.
Each sheet contains three pivot tables, these pivot tables have three source sheets.
All three source sheets have one column in common the customer ID, and therefore, the three pivot tables are filtered on Page Filed “GL_ID”, i.e. customer ID.
Every day, we run another macro that compiles a dynamic list of customer IDs, and out of this list, we create a changeable number sheets, this macro also pastes three pivots on those sheets, it also prints the customer ID on cell B2 of each sheet (each sheet contains, (1) balance, (2) possible trading activity and (3) possible product change reports of a customer).
-      Pivot table one contains; all customer IDs
-      Pivot table two and three, however, may or may not contain every customer ID printed on cell B2.
What I would like to do and kindly ask your help, is a macro that filters each pivot table in each sheet, by setting the page fields equal to the value of cell B2?
But also importantly before that, it tests, if the pivot item in cell B2 is to be found in the drop down list of the pivot tables (page field), epically on pivot table two and three .
-      If the pivot Item is found = filter each pivot table based on cell B2.
-      Else ignore and go to the next pivot table.
Thank you in advance,
Regards,
Jay

Ejgil Hedegaard

Try this

Option Explicit

Sub FilterPivotTablesOnId()
    Dim ws As Worksheet, wsData As Worksheet
    Dim pt As PivotTable
    Dim ptAdr As Variant
    Dim strDataSheet As String, strDataRange As String
    Dim arData As Variant
    Dim rwData As Long, colId As Integer, col As Integer
    Dim strId As String
    Dim bIdFound As Boolean
    
    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        strId = ws.Range("B2")
        For Each pt In ws.PivotTables
            ptAdr = pt.SourceData
            strDataSheet = Replace(Left(ptAdr, InStr(1, ptAdr, "!") - 1), "'", "")
            Set wsData = ThisWorkbook.Worksheets(strDataSheet)
            strDataRange = Application.ConvertFormula(Right(ptAdr, Len(ptAdr) - InStr(1, ptAdr, "!")), xlR1C1, xlA1)
            arData = wsData.Range(strDataRange)
            colId = 0
            For col = 1 To UBound(arData, 2)
                If arData(1, col) = "GL_ID" Then
                    colId = col
                    Exit For
                End If
            Next col
            If colId > 0 Then
                bIdFound = False
                For rwData = 2 To UBound(arData, 1)
                    If arData(rwData, colId) = strId Then
                        bIdFound = True
                        Exit For
                    End If
                Next rwData
                If bIdFound Then
                    pt.PivotFields("GL_ID").CurrentPage = strId
                End If
            End If
        Next pt
    Next ws
End Sub

Open in new window

Ejgil Hedegaard

I guess the error is because the pivot does not have GL_ID as page filter.

Here is the code with comments, and a check that GL_ID exists as page field.
If it does not work, please upload a file with the setup.
You can use dummy data if you like.

Option Explicit

Sub FilterPivotTablesOnId()
    Dim ws As Worksheet, wsData As Worksheet
    Dim pt As PivotTable
    Dim ptField As PivotField
    Dim ptAdr As Variant
    Dim strDataSheet As String, strDataRange As String
    Dim arData As Variant
    Dim rwData As Long, colId As Integer, col As Integer
    Dim strId As String
    Dim bIdFound As Boolean, bFieldFound As Boolean
    
    Application.ScreenUpdating = False
    
    'Loop all sheets
    For Each ws In ThisWorkbook.Worksheets
        'ID from B2 on sheet
        strId = ws.Range("B2")
        'Loop all pivottables on the sheet
        For Each pt In ws.PivotTables
            'Source data for the pivot
            ptAdr = pt.SourceData
            'Source data sheet name
            strDataSheet = Replace(Left(ptAdr, InStr(1, ptAdr, "!") - 1), "'", "")
            Set wsData = ThisWorkbook.Worksheets(strDataSheet)
            'Convert source range from R1C1 notation to A1 notation
            strDataRange = Application.ConvertFormula(Right(ptAdr, Len(ptAdr) - InStr(1, ptAdr, "!")), xlR1C1, xlA1)
            'Load source range to array
            arData = wsData.Range(strDataRange)
            'Find the column with header GL_ID
            colId = 0
            For col = 1 To UBound(arData, 2)
                If arData(1, col) = "GL_ID" Then
                    colId = col
                    Exit For
                End If
            Next col
            'Continue if GL_ID found as header in data
            If colId > 0 Then
                'Check if ID in source data
                bIdFound = False
                For rwData = 2 To UBound(arData, 1)
                    If arData(rwData, colId) = strId Then
                        bIdFound = True
                        Exit For
                    End If
                Next rwData
                'Continue if ID found
                If bIdFound Then
                    'Check if GL_ID is in page field
                    bFieldFound = False
                    For Each ptField In pt.PageFields
                        If ptField.Name = "GL_ID" Then
                            bFieldFound = True
                        End If
                    Next ptField
                    'If GL_ID exist as page field, then set it to ID
                    If bFieldFound Then
                        pt.PivotFields("GL_ID").CurrentPage = strId
                    End If
                End If
            End If
        Next pt
    Next ws
End Sub

Open in new window

Jay Xhashy

ASKER

Here attached is the file.

I've used a dummy data.

Thanks
Jay
Pivot-Table-change1.01_0001x.xlsm

ASKER CERTIFIED SOLUTION

Ejgil Hedegaard

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Jay Xhashy

ASKER

Brilliant, it is just brilliant,

It works, thank you very much

I wonder do you by any chance offer or provide courses?

Thank you very much,

Regards,
Jay

Ejgil Hedegaard

No, I don't offer or provide courses.