pulsar777
01-31-2018, 07:08 PM
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
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