PDA

View Full Version : VBA_Pivot table capture in array and reapply



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

pulsar777
02-01-2018, 10:10 AM
Any suggestions please ?