V
vjammy
My issue is pretty similar to:
http://www.dailydoseofexcel.com/archives/2008/05/21/pivottable-markup-language/
I have a pivot table and i want to filter items programatically. The
number of items in the pivot table are 15000, and i want to choose
20,and deselect the rest.
i tried it using the code below, it works but it is amazingly slow. It
takes abt 20-30 minutes to do the same.
explanation of the code -
the range - rgClass refers to the config space, which i use to
configure sheet name, pivottable name and field name.
rgNew is the range where the actual items to filter are stored.
then i try to loop through the sheet, and set all pivot items to
false, then i loop the items in the rgnew range, and try to set them
to visible in the pivot table.
This works, but can you help me with a better way of doing this? The
user will not sit for 20 minutes, waiting for the pivot to refresh.
I also tried :
Dim strIDs(5) As String
strIDs(0) = "1"
strIDs(1) = "2"
strIDs(2) = "3"
strIDs(3) = "4"
strIDs(4) = "5"
Dim pt As PivotTable
Dim pi As PivotItem
Dim pf As PivotField
Set pt =
Sheets("Themes_Metrics").PivotTables("PivotTable1")
Set pf = pt.PivotFields("Company_ID")
pf.VisibleItemsList = strIDs
but this did not work. I guess it only works with cubes?
Here's the code:
Sub ApplyPivotFilter()
'On Error Resume Next
On Error Resume Next
Dim strStartCell, strStartTicker, strMainSheet As String
strStartCell = "Y1"
strStartTicker = "B22"
strMainSheet = "Control"
Dim rgNew, rgClass As Range
Dim intLoop, intMax, intClass As Integer
Dim strSheet, strPivot, strFilter As String
intLoop = 1
intClass = 0
Application.ScreenUpdating = False
Set rgClass = Sheets(strMainSheet).Range(strStartCell).Offset(0,
1)
Set rgNew = Sheets(strMainSheet).Range(strStartTicker)
' If rgClass.Offset(0, intClass) <> "" Then
Do While rgClass.Offset(0, intClass) <> ""
strSheet = rgClass.Offset(0, intClass)
strPivot = rgClass.Offset(1, intClass)
strFilter = rgClass.Offset(2, intClass)
'Set rgNew = rgNew.Offset(0, intClass)
'Set rgNew = rgClass.Offset(3, intClass)
Set rgNew = Sheets(strMainSheet).Range(strStartTicker)
If strSheet <> "" And strPivot <> "" And strFilter <> "" And
rgNew.Value <> "" Then
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter). _
EnableMultiplePageItems = True
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter).ClearAllFilters
If UCase(rgNew.Value) <> UCase("(All)") Then
Dim pt As PivotTable
Dim pi As PivotItem
Dim pf As PivotField
Set pt = Sheets(strSheet).PivotTables(strPivot)
Set pf = pt.PivotFields(strFilter)
pt.ManualUpdate = False
pt.ManualUpdate = True
' For Each pi In pf.PivotItems
' pi.Visible = False
' Next pi
For Each pi In pf.PivotItems
If pi = rgNew.Value Then
pi.Visible = True
Else
pi.Visible = False
End If
Next pi
pt.ManualUpdate = False
'intMax = rgNew.CurrentRegion.Rows.Count
Do While rgNew.Value <> ""
With
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter)
.PivotItems(rgNew.Value).Visible = True
End With
Set rgNew = rgNew.Offset(1, 0)
'intLoop = intLoop + 1
Loop
End If
End If
intClass = intClass + 1
Loop
Application.ScreenUpdating = True
End Sub
http://www.dailydoseofexcel.com/archives/2008/05/21/pivottable-markup-language/
I have a pivot table and i want to filter items programatically. The
number of items in the pivot table are 15000, and i want to choose
20,and deselect the rest.
i tried it using the code below, it works but it is amazingly slow. It
takes abt 20-30 minutes to do the same.
explanation of the code -
the range - rgClass refers to the config space, which i use to
configure sheet name, pivottable name and field name.
rgNew is the range where the actual items to filter are stored.
then i try to loop through the sheet, and set all pivot items to
false, then i loop the items in the rgnew range, and try to set them
to visible in the pivot table.
This works, but can you help me with a better way of doing this? The
user will not sit for 20 minutes, waiting for the pivot to refresh.
I also tried :
Dim strIDs(5) As String
strIDs(0) = "1"
strIDs(1) = "2"
strIDs(2) = "3"
strIDs(3) = "4"
strIDs(4) = "5"
Dim pt As PivotTable
Dim pi As PivotItem
Dim pf As PivotField
Set pt =
Sheets("Themes_Metrics").PivotTables("PivotTable1")
Set pf = pt.PivotFields("Company_ID")
pf.VisibleItemsList = strIDs
but this did not work. I guess it only works with cubes?
Here's the code:
Sub ApplyPivotFilter()
'On Error Resume Next
On Error Resume Next
Dim strStartCell, strStartTicker, strMainSheet As String
strStartCell = "Y1"
strStartTicker = "B22"
strMainSheet = "Control"
Dim rgNew, rgClass As Range
Dim intLoop, intMax, intClass As Integer
Dim strSheet, strPivot, strFilter As String
intLoop = 1
intClass = 0
Application.ScreenUpdating = False
Set rgClass = Sheets(strMainSheet).Range(strStartCell).Offset(0,
1)
Set rgNew = Sheets(strMainSheet).Range(strStartTicker)
' If rgClass.Offset(0, intClass) <> "" Then
Do While rgClass.Offset(0, intClass) <> ""
strSheet = rgClass.Offset(0, intClass)
strPivot = rgClass.Offset(1, intClass)
strFilter = rgClass.Offset(2, intClass)
'Set rgNew = rgNew.Offset(0, intClass)
'Set rgNew = rgClass.Offset(3, intClass)
Set rgNew = Sheets(strMainSheet).Range(strStartTicker)
If strSheet <> "" And strPivot <> "" And strFilter <> "" And
rgNew.Value <> "" Then
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter). _
EnableMultiplePageItems = True
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter).ClearAllFilters
If UCase(rgNew.Value) <> UCase("(All)") Then
Dim pt As PivotTable
Dim pi As PivotItem
Dim pf As PivotField
Set pt = Sheets(strSheet).PivotTables(strPivot)
Set pf = pt.PivotFields(strFilter)
pt.ManualUpdate = False
pt.ManualUpdate = True
' For Each pi In pf.PivotItems
' pi.Visible = False
' Next pi
For Each pi In pf.PivotItems
If pi = rgNew.Value Then
pi.Visible = True
Else
pi.Visible = False
End If
Next pi
pt.ManualUpdate = False
'intMax = rgNew.CurrentRegion.Rows.Count
Do While rgNew.Value <> ""
With
Sheets(strSheet).PivotTables(strPivot).PivotFields(strFilter)
.PivotItems(rgNew.Value).Visible = True
End With
Set rgNew = rgNew.Offset(1, 0)
'intLoop = intLoop + 1
Loop
End If
End If
intClass = intClass + 1
Loop
Application.ScreenUpdating = True
End Sub