Exporting multiple Pivot Tables/Charts from a wb to another

[deltaquattro]

Hi guys,

I wrote a VBA code in Excel 2000 which automatically generates Pivot Charts from some data and exports them in a new workbook. This nifty piece of code worked fine...until I had to migrate to Office 2007, that is

The issue is the following: I create Pivot Tables and associated Pivot Charts in worbook Test.xlsm, and this works fine. I then try to export them to a separate workbook, PivotReport.xlsx. When I do this, the "link" between the Pivot Tables and the Pivot Charts is broken, and my charts now become ordinary Chart sheets, so I cannot change the Field Items, I cannot filter them, etc.
I enclose the sample workbook, where I put a simplified version of the code. The problem appears when the subroutine MoveSheetsToWorkbook is executed: until that point, the Pivot Charts are still real Pivot Charts, with the associated Tags.
I cannot attach an example workbook since this is forbidden on this forum, so I pasted the code: this assumes that you have the following data in a sheet "Data" in the wb where you put the code.

<table width="332" border="0" cellpadding="0" cellspacing="0" height="189"><col style="width:54pt" width="72" span="5"> <tbody><tr style="height:15.75pt" height="21"> <td style="height:15.75pt;width:54pt" width="72" height="21">a</td> <td style="width:54pt" width="72">b</td> <td style="width:54pt" width="72">c</td> <td style="width:54pt" width="72">sum</td> <td style="width:54pt" width="72">mult</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">1</td> <td align="right">9</td> <td align="right">17</td> <td align="right">27</td> <td align="right">153</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">2</td> <td align="right">10</td> <td align="right">18</td> <td align="right">30</td> <td align="right">360</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">3</td> <td align="right">11</td> <td align="right">19</td> <td align="right">33</td> <td align="right">627</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">4</td> <td align="right">12</td> <td align="right">20</td> <td align="right">36</td> <td align="right">960</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">5</td> <td align="right">13</td> <td align="right">21</td> <td align="right">39</td> <td align="right">1365</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">6</td> <td align="right">14</td> <td align="right">22</td> <td align="right">42</td> <td align="right">1848</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">7</td> <td align="right">15</td> <td align="right">23</td> <td align="right">45</td> <td align="right">2415</td> </tr> <tr style="height:15.75pt" height="21"> <td style="height:15.75pt" align="right" height="21">8</td> <td align="right">16</td> <td align="right">24</td> <td align="right">48</td> <td align="right">3072</td> </tr> </tbody></table>

Option Explicit

Sub CreateReport()
' Create Pivot Tables from Data and save thme in a new workbook
Dim SheetName As String, NumProperties As Long, wbkName As String, SheetsToKeep() As String

Application.ScreenUpdating = False
' Create Pivot Reports summarizing stage performances
SheetName = "Data"
NumProperties = 5
Call CreatePivotCharts(NumProperties, SheetName)

'Move all sheets except the ones in SheetsToKeep to workbook wbkName, creating it if it is missing
wbkName = "PivotReports"
ReDim SheetsToKeep(1)
SheetsToKeep(1) = "Data"
Call MoveSheetsToWorkbook(SheetsToKeep, wbkName) 'ERROR IS PROBABLY INSIDE THIS ONE
Application.ScreenUpdating = True

End Sub
Sub CreatePivotCharts(NumProperties As Long, SheetName As String)
'Creates multiple PivotTables and PivotCharts associated with the data stored in
'sheet SheetName
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim SummarySheet As Worksheet, sht As Worksheet
Dim cht As Chart
Dim I As Long, Row As Long
Dim NumTables As Long, Index As Long
Dim ItemName As String

'Set a pointer to the sheet containing the source data
Set sht = Sheets(SheetName)

'All PivotTables are stored in a single sheet, called PivotTables
'Delete PivotTables sheet if exists
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("PivotTables").Delete
On Error GoTo 0
' Create PivotTables sheet
Set SummarySheet = Worksheets.Add
With SummarySheet
    .Move After:=Worksheets(Worksheets.Count)
    .Name = "PivotTables"
End With


'Create Pivot Cache
Set PTCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=sht.Range("A1").CurrentRegion.Address)
    
' Create Pivot Tables and PivotCharts
NumTables = NumProperties - 3
Row = 8
For I = 1 To NumTables
    Index = I + 3
    Set PT = PTCache.CreatePivotTable( _
    TableDestination:=SummarySheet.Cells(Row, 1))
    
    'Add fields
    With PT
        
        'Rows
        ItemName = sht.Cells(1, 1) 'a
        .PivotFields(ItemName).Orientation = xlRowField
        ItemName = sht.Cells(1, 2) 'b
        .PivotFields(ItemName).Orientation = xlRowField
        
        'Columns 'make it a subroutine!
        ItemName = sht.Cells(1, 3) 'c
        .PivotFields(ItemName).Orientation = xlColumnField
        
        'Data 'make it a subroutine!
        ItemName = sht.Cells(1, Index)
        With .PivotFields(ItemName)
            .Orientation = xlDataField
            .Function = xlSum
        End With
        
    End With
    
    ' Add associated PivotChart
    Call AddPivotChart(PT, ItemName, cht)
      
    'The active sheet is cht: reactivate PivotTables before adding a new Chart
    'otherwise the chart points by default to the active sheet and it's not possible
    'to change the data source of a PivotChart
    SummarySheet.Activate
    
    Row = Row + PT.TableRange1.Rows.Count + 8 ' 8 rows of space between each PivotTable

Next I

End Sub
Sub AddPivotChart(PT As PivotTable, ChartName As String, cht As Chart)
' Add a PivotChart associated with PivotTable PT
        
' Add the Chart ChartName as the last sheet in the active workbook:
' if the chart already exists, it's deleted before adding it again
On Error Resume Next
Application.DisplayAlerts = False
Sheets(ChartName).Delete
On Error GoTo 0
' Add chart
Set cht = Charts.Add
With cht
    .Move After:=Sheets(Sheets.Count)
    .Name = ChartName
End With

With cht

    .Name = ChartName
    .SetSourceData Source:=PT.TableRange1
    ActiveWorkbook.ShowPivotChartActiveFields = True
       
    'Add title
    .HasTitle = True
    .ChartTitle.Text = ChartName
    
    'Change format
    .ChartType = xlLineMarkers
        
End With
    
End Sub
Sub MoveSheetsToWorkbook(SheetsToKeep() As String, wbkName As String)
'Move all sheets except the ones in SheetsToKeep to workbook StageName, creating it if it is missing
Dim sht As Object, SheetsToMove() As String, Index As Long, Path As String, FullName As String
Dim wbk As Workbook

' Crete array with the names of the sheets to be exported
ReDim SheetsToMove(1 To Sheets.Count - UBound(SheetsToKeep))
Index = 0
For Each sht In Sheets
    If IsError(Application.Match(sht.Name, SheetsToKeep, 0)) Then
        Index = Index + 1
        SheetsToMove(Index) = sht.Name
    End If
Next

'Export the sheets
Path = ActiveWorkbook.Path
Sheets(SheetsToMove).Move 'WHEN THIS INSTRUCTION IS EXECUTED, I LOSE THE LINKS BETWEEN MY PIVOT TABLES AND
                        'THE PIVOT CHARTS
FullName = Path & "\" & wbkName
ActiveWorkbook.SaveAs Filename:=FullName
Set wbk = ActiveWorkbook

End Sub

Let me know if there's something I should clarify,

Thanks,

Sergio Rossi