VBA_Pivot table capture in array and reapply

[pulsar777]

Hi, I'm trying to capture layout and visible pivot table items into array with a function.
Then with another function to reapply same layout with filters based on the array.

Here's the code :

Option Explicit


Sub test()


    Dim Arr As Variant
    
    Arr = PivotTable_Capture(ActiveSheet.Range("A2"))
    
    Call PivotTable_Reapply(Arr, ActiveSheet.PivotTables(1))
    
    
    
End Sub


Function PivotTable_Capture(Rng As Range) As Variant
    
    ' captures pivot table layout and filtered items into Array
    
    Dim pt As PivotTable
    Dim pf As PivotField
    Dim pi As PivotItem
    'Dim pc As PivotCache
    Dim rowFields(), rowFilter() As String
    Dim colFields(), colFilter() As String
    Dim pageFields(), pageFilter() As String
    Dim dataFields() As String      ' filters here dealt different way
    Dim i As Integer, j As Integer, k As Integer, m As Integer
    Dim e As Integer, f As Integer, g As Integer, h As Integer
    Dim n As Long, o As Long, p As Long
    Dim totalArray
    
    Set pt = Rng.PivotTable
    
    With pt
        
        For Each pf In .PivotFields
            If pf.Orientation = xlRowField Then i = i + 1
            If pf.Orientation = xlColumnField Then j = j + 1
            If pf.Orientation = xlPageField Then k = k + 1
            'If pf.Orientation = xlDataField Then m = m + 1         ' can be named different way; Sum of Dollars instead of Dollar
        Next pf
        
        For Each pf In .dataFields
            m = m + 1
        Next pf
        
        ReDim rowFields(1 To i, 1 To 3)
        ReDim colFields(1 To j, 1 To 3)
        ReDim pageFields(1 To k, 1 To 3)
        ReDim dataFields(1 To m)
      
        For Each pf In .VisibleFields
        
            Select Case pf.Orientation
            
                Case xlRowField
                
                    e = e + 1
                    rowFields(e, 1) = pf.Name
                    rowFields(e, 2) = pf.Position
                    
                    n = 0
                    For Each pi In pf.VisibleItems
                        n = n + 1
                        ReDim Preserve rowFilter(1 To n)
                        rowFilter(n) = pi.Value
                    Next pi
                    rowFields(e, 3) = rowFilter
                    
                Case xlColumnField
                    
                    f = f + 1
                    colFields(f, 1) = pf.Name
                    colFields(f, 2) = pf.Position
                    
                    o = 0
                    For Each pi In pf.VisibleItems
                        o = o + 1
                        ReDim Preserve colFilter(1 To o)
                        colFilter(o) = pi.Value
                    Next pi
                    colFields(f, 3) = colFilter
                    
                Case xlPageField
                    
                    g = g + 1
                    pageFields(g, 1) = pf.Name
                    pageFields(g, 2) = pf.Position
                    
                    p = 0
                    For Each pi In pf.VisibleItems
                        p = p + 1
                        ReDim Preserve pageFilter(1 To p)
                        pageFilter(p) = pi.Value
                    Next pi
                    pageFields(g, 3) = pageFilter
                    
                Case xlDataField
                   
                    If InStr(pf.Name, " ") <> 0 Then
                        dataFields(m) = Mid(pf.Name, InStrRev(pf.Name, " ") + 1)
                    Else
                        dataFields(m) = pf.Name
                    End If
                    m = m + 1
                    
                Case Else
                    ' invisible / invalid
            End Select
        Next pf
    
    End With
    
    totalArray = Array(rowFields, colFields, pageFields, dataFields)
    PivotTable_Capture = totalArray
    
End Function


Function PivotTable_Reapply(pivotStructure As Variant, pt As PivotTable)
    
    Dim i As Integer, j As Integer, k As Integer
    Dim v As Variant
    Dim pf As PivotField, pi As PivotItem
    
    Application.DisplayAlerts = False
    pt.ClearTable
    Application.DisplayAlerts = True
    
    For i = LBound(pivotStructure) To UBound(pivotStructure)
        For j = LBound(pivotStructure(i)) To UBound(pivotStructure(i))
        
            For k = LBound(pivotStructure(i)) To UBound(pivotStructure(i))
                If pivotStructure(i)(k, 2) = j Then         ' Position from 1 ....
                
                    Select Case i
                        Case 0
                            pt.AddFields rowFields:=pivotStructure(i)(k, 1)
                            Set pf = pt.rowFields(j)
                            Exit For
                        Case 1
                            pt.AddFields ColumnFields:=pivotStructure(i)(k, 1)
                            Set pf = pt.ColumnFields(j)
                            Exit For
                        Case 2
                            pt.AddFields pageFields:=pivotStructure(i)(k, 1)
                            Set pf = pt.pageFields(j)
                            Exit For
                        Case 3
                            pt.AddDataField field:=pivotStructure(i)(k, 1), Caption:="Sum of " & pivotStructure(i)(k, 1), Function:=xlSum
                            Set pf = pt.dataFields(j)
                            Exit For
                    End Select
                    
                    If Not pf.Orientation = xlDataField Then
                        If pf.Orientation = xlPageField And LBound(pivotStructure(i)(k, 3)) = UBound(pivotStructure(i)(k, 3)) Then
                            pf.CurrentPage = pivotStructure(i)(k, 3)
                        Else
                            For Each v In pivotStructure(i)(k, 3)
                                Set pi = pf.PivotItems(v)
                                pi.Visible = True
                            Next v
                        End If
                    End If
                End If
            Next k
        Next j
    Next i
    
End Function

Problem appears with the Reappy function where not whole fields are "dropped" in the pivot table.
For example a row fields named "TYPE" would have 10 visible out of 100 items, but after adding it to table,

 pt.AddFields rowFields:=pivotStructure(i)(k, 1)

it would show only last filtered one

[pulsar777]

Any suggestions please ?