Filter a pivot table with large number of unique items in the filterlist

[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

 

[incre-d]

You'v got this bit of code

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


why are you setting pt.ManualUpdate = true
?