Use vba to iterate through pivot items

[Trebormac]

Hi All,

I am using Excel 2003 and I have a pivot table with about 50 pivot items that I need to iterate through, making each one visiible individually , then copy the pivot table and paste it into a new workbook and the move on to the next pivot item and do the same.

When I execute the code I get this error message:
Run-time error '1004'
Unable to set the Visible property of the Pivot Item class.

Which occurs when trying to run


PivotItems(i).Visible = True

Option Explicit
Sub PivotStockItems()
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Country")
Dim i As Integer
For i = 2 To .PivotItems.Count
If .PivotItems(i).Visible = False Then
.PivotItems(i).Visible = True
.PivotItems(1).Visible = False
Cells.Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
.PivotItems(1).Visible = True
.PivotItems(i).Visible = False
End If
Next i
End With
End Sub

i would appreciate any suggestions.

Thanks,

Trebormac

 

[Jerry Sullivan]

Hi Trebormac,

One possibility is that you have missing items that have been deleted from your data source, but are still retained in PivotItems.
You can check that by seeing whether your filter list for that field includes items that you no longer have in your data source.

Below is a rework of your code that includes a statement to clear missing items.

Also, you might not want to have all ~50 workbooks open at the same time and then have to manually save and close each one.
I added a statement to save each workbook to a designated folder.

Sub PivotStockItems()
    Dim i As Integer
    Dim sItem As String
    Application.ScreenUpdating = False
    With ActiveSheet.PivotTables("PivotTable1")
        .PivotCache.MissingItemsLimit = xlMissingItemsNone
        .PivotCache.Refresh
        With .PivotFields("Country")
            '---hide all items except item 1
            .PivotItems(1).Visible = True
            For i = 2 To .PivotItems.Count
                .PivotItems(i).Visible = False
            Next
            For i = 1 To .PivotItems.Count
                .PivotItems(i).Visible = True
                If i <> 1 Then .PivotItems(i - 1).Visible = False
                sItem = .PivotItems(i)
                Cells.Copy
                Workbooks.Add
                With ActiveWorkbook
                    .Sheets(1).Cells(1).PasteSpecial _
                        Paste:=xlPasteValuesAndNumberFormats
                    .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                        FileFormat:=xlOpenXMLWorkbook
                    .Close
                End With
            Next i
        End With
    End With
End Sub

 

[Trebormac]

Thanks, Jerry I will try it.
Trebormac

 

[Trebormac]

Jerry,

Except for Paste Special, itt worked just fine. I need to paste the actual pivot table not just their values. I tweeked it and its great!!

Thanks much
Trebormac

 

[Jerry Sullivan]

Trebormac, Glad to hear that worked. Based on your original code, I thought you wanted to just Paste the Values and Formats.

If you want the whole PivotTable, I'd recommend changing the lines highlighted below.
In addition to being more efficient, this will bring over the other sheet formatting like the column widths.

Change this...

            For i = 1 To .PivotItems.Count
                .PivotItems(i).Visible = True
                If i <> 1 Then .PivotItems(i - 1).Visible = False
                sItem = .PivotItems(i)
                Cells.Copy
                Workbooks.Add
                With ActiveWorkbook 
                    .Sheets(1).Cells(1).PasteSpecial _
                        Paste:=xlPasteValuesAndNumberFormats                    
                        .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                        FileFormat:=xlOpenXMLWorkbook
                    .Close
                End With
            Next i

To this...

            For i = 1 To .PivotItems.Count
                .PivotItems(i).Visible = True
                If i <> 1 Then .PivotItems(i - 1).Visible = False
                sItem = .PivotItems(i)
                ActiveSheet.Copy
                With ActiveWorkbook
                    .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                        FileFormat:=xlOpenXMLWorkbook
                    .Close
                End With
            Next i

Cheers!

 

[Trebormac]

Thanks, Jerry...but don't we need a 'Paste' after the 'Copy"?

Trebormac

 

[Jerry Sullivan]

Thanks, Jerry...but don't we need a 'Paste' after the 'Copy"?

No, not in this case.
The statement:
ActiveSheet.Copy

is the same as manually doing this:
Right-Click on Sheet Tab
Move or Copy...
Move selected sheets to Book: (new book)
Check the Create a Copy checkbox

 

[Trebormac]

Jerry,

Yes it works great. Thanks for your help.

best,

Trebormac

 

[GregFrie]

Hello!

I know this thread is very old but I found it working on a similar problem. So far I have built the macro(well adjusted what I found on google) to create a sheet per pivot item within that same workbook. What I need, however, is a workbook saved per pivotitem with only values and number formatting. I tried to merge your code with mine but I am not getting what I need.

Here is my code:

Sub CopyPivotPages()

On Error GoTo errHandler
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strPF As String
Dim strPI As String

strPF = "Customer Name"
Set ws = Sheets("AR DETAIL BY CUST 31+ days")
Set pt = ws.PivotTables(1)
Set pf = pt.PivotFields(strPF)

For Each pi In pf.PivotItems
strPI = Left("PT_" & pi.Name, 31)
On Error Resume Next
Sheets(strPI).Delete
On Error GoTo 0
ws.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = strPI
With .PivotTables(1).PivotFields(strPF)
.PivotItems(pi.Name).Visible = True
.CurrentPage = pi.Name
End With
End With
Next pi

ws.Activate

exitHandler:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub

errHandler:
MsgBox "Could not create sheets"
Resume exitHandler

End Sub

Any help is greatly appreciated!!!
Thanks,
Greg

 

[maw230]

Hi Trebormac,

One possibility is that you have missing items that have been deleted from your data source, but are still retained in PivotItems.
You can check that by seeing whether your filter list for that field includes items that you no longer have in your data source.

Below is a rework of your code that includes a statement to clear missing items.

Also, you might not want to have all ~50 workbooks open at the same time and then have to manually save and close each one.
I added a statement to save each workbook to a designated folder.

Sub PivotStockItems()
    Dim i As Integer
    Dim sItem As String
    Application.ScreenUpdating = False
    With ActiveSheet.PivotTables("PivotTable1")
        .PivotCache.MissingItemsLimit = xlMissingItemsNone
        .PivotCache.Refresh
        With .PivotFields("Country")
            '---hide all items except item 1
            .PivotItems(1).Visible = True
            For i = 2 To .PivotItems.Count
                .PivotItems(i).Visible = False
            Next
            For i = 1 To .PivotItems.Count
                .PivotItems(i).Visible = True
                If i <> 1 Then .PivotItems(i - 1).Visible = False
                sItem = .PivotItems(i)
                Cells.Copy
                Workbooks.Add
                With ActiveWorkbook
                    .Sheets(1).Cells(1).PasteSpecial _
                        Paste:=xlPasteValuesAndNumberFormats
                    .SaveAs "C:\TEST\MyReport-" & sItem & ".xlsx", _
                        FileFormat:=xlOpenXMLWorkbook
                    .Close
                End With
            Next i
        End With
    End With
End Sub

Just posting to say thanks for this code!