Using Excel 2010, I have written some VBA to copy selected sheets from a Master workbook to a Client workbook. The code works just fine to copy the data sheet which has data & PivotTable(s) associated with the data, and the chart sheet with one or more PivotCharts to the new workbook.
The issue is that in the destination workbook, the charts are no longer PivotCharts, they're regular Charts and their Source Data range is blank. The Source Data for the Master PivotChart is filled in, but greyed out so it's not editable.
The issue appears immediately upon copying the worksheet from one workbook to the other (on this line: XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)), though I'll include the code for the call Subs. By the time it gets to those lines, the chart is already broken
The question is three part:
- Can I prevent the PivotChart being converted into a regular Chart in the copy? i.e. is there a flag/setting for
.Copythat I've missed? - If not, can I update the chart to be a PivotChart again by something along the lines of
cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable? - Failing either of these, what's the best way to create the PivotChart from scratch in the copied worksheet?
NOTES:
- These are standard Excel PivotTables, I'm not using PowerPivot. I'm open to that, though, if it will fix the issue. Having just done a little reading on PowerPivot, I don't think it will help me, but, again, I'm open to suggestion.
- In response to Jens' comment, the raw data and Pivot Tables are on one sheet, and the Pivot Charts are on a second sheet.
Here's the code. It is working great for everything except copying a sheet with a PivotChart intact as a PivotChart.
While Not SlideRS.EOF 'loop through all the supporting data sheets for this graph sheet
If SlideRS.Fields(1) <> SlideRS.Fields(2) Then 'the worksheet depends on something else, copy it first
If InStr(1, UsedSlides, SlideRS.Fields(2)) = 0 Then 'if the depended upon slide is not in the list of UsedSlides, then add it
Form_Master.ProcessStatus.Value = "Processing: " & ClinicName & " Slide: " & SlideRS!SlideName & " Worksheet: " & SlideRS.Fields(2).Value
XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)
Set NewSheet = XLClinic.Sheets(XLClinic.Sheets.Count)
UsedSlides = UsedSlides & "," & NewSheet.Name
UpdateCharts XLMaster.Sheets(SlideRS.Fields(2).Value), NewSheet
ProcessDataSheet NewSheet, NewXLName
Set NewSheet = Nothing
End If
End If
SlideRS.MoveNext 'move to the next record of supporting Data sheets
Wend
Here is the code for UpdateCharts. Its purpose is to copy the colors from the Master to the Client worksheet, since Excel seems to like assigning random colors to the new charts
Private Sub UpdateCharts(ByRef Master As Worksheet, ByRef Clinic As Worksheet)
Dim MChart As Excel.ChartObject
Dim CChart As Excel.ChartObject
Dim Ser As Excel.Series
Dim pnt As Excel.point
Dim i As Integer
Dim Color() As Long
Dim ColorWheel As ChartColors
Set ColorWheel = New ChartColors
For Each MChart In Master.ChartObjects
For Each CChart In Clinic.ChartObjects
If CChart.Name = MChart.Name Then
If CChart.Chart.ChartType = xlPie Or _
CChart.Chart.ChartType = xl3DPie Or _
CChart.Chart.ChartType = xl3DPieExploded Or _
CChart.Chart.ChartType = xlPieExploded Or _
CChart.Chart.ChartType = xlPieOfPie Then
If InStr(1, CChart.Name, "ColorWheel") Then 'this pie chart needs to have pre-defined colors assigned
i = 1
For Each pnt In CChart.Chart.SeriesCollection(1).Points
pnt.Format.Fill.ForeColor.RGB = ColorWheel.GetRGB("Pie" & i)
i = i + 1
Next
Else 'just copy the colors from XLMaster
'collect the colors for each point in the SINGLE series in the MASTER pie chart
i = 0
For Each Ser In MChart.Chart.SeriesCollection
For Each pnt In Ser.Points
ReDim Preserve Color(i)
Color(i) = pnt.Format.Fill.ForeColor.RGB
i = i + 1
Next 'point
Next 'series
'take that collection of colors and apply them to the CLINIC pie chart points
i = 0
For Each Ser In CChart.Chart.SeriesCollection
For Each pnt In Ser.Points
pnt.Format.Fill.ForeColor.RGB = Color(i)
i = i + 1
Next 'point
Next 'series
End If
Else
'get the series colors from the MASTER
i = 0
For Each Ser In MChart.Chart.SeriesCollection
ReDim Preserve Color(i)
Color(i) = Ser.Interior.Color
i = i + 1
Next 'series
'assign them to the CLINIC
i = 0
For Each Ser In CChart.Chart.SeriesCollection
Ser.Interior.Color = Color(i)
i = i + 1
Next 'series
End If 'pie chart
End If 'clinic chart = master chart
Next 'clinic chart
Next 'master chart
Set ColorWheel = Nothing
End Sub
Here is the ProcessDataSheet() code. This will update the data on the sheet based on one or more SQL queries embedded in the sheet.
Private Sub ProcessDataSheet(ByRef NewSheet As Excel.Worksheet, ByRef NewXLName As String)
Const InstCountRow As Integer = 1
Const InstCountCol As Integer = 2
Const InstDataCol As Integer = 2
Const InstCol As Integer = 3
Const ClinicNameParm As String = "{ClinicName}"
Const LikeClinicName As String = "{LikeClinicName}"
Const StartDateParm As String = "{StartDate}"
Const EndDateParm As String = "{EndDate}"
Const LocIDParm As String = "{ClinicLoc}"
Dim Data As New ADODB.Recordset
Dim InstCount As Integer
Dim SQLString As String
Dim Inst As Integer
Dim pt As Excel.PivotTable
Dim Rng As Excel.Range
Dim Formula As String
Dim SChar As Integer
Dim EChar As Integer
Dim Bracket As Integer
Dim TabName As String
Dim RowCol() As String
'loop through all the instructions on the page and update the appropriate data tables
InstCount = NewSheet.Cells(InstCountRow, InstCountCol)
For Inst = 1 To InstCount
RowCol = Split(NewSheet.Cells(InstCountRow + Inst, InstDataCol), ",")
SQLString = NewSheet.Cells(InstCountRow + Inst, InstCol)
SQLString = Replace(SQLString, """", "'")
If InStr(1, SQLString, LikeClinicName) > 0 Then
SQLString = Replace(SQLString, LikeClinicName, "'" & ClinicSystoc & "%'")
Else
SQLString = Replace(SQLString, ClinicNameParm, "'" & ClinicSystoc & "'")
End If
SQLString = Replace(SQLString, LocIDParm, "'" & ClinicLocID & "%'")
SQLString = Replace(SQLString, StartDateParm, "#" & StartDate & "#")
SQLString = Replace(SQLString, EndDateParm, "#" & EndDate & "#")
Data.Open Source:=SQLString, ActiveConnection:=CurrentProject.Connection
If Not Data.EOF And Not Data.BOF Then
NewSheet.Cells(CInt(RowCol(0)), CInt(RowCol(1))).CopyFromRecordset Data
End If
Data.Close
Next
'search for all external sheet refrences and truncate them so it points to *this* worksheet
Set Rng = NewSheet.Range(NewSheet.Cells.Address).Find(What:=XLMasterFileName, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False)
While Not Rng Is Nothing
Formula = Rng.Cells(1, 1).Formula
If InStr(1, Formula, "'") > 0 Then
SChar = InStr(1, Formula, "'")
EChar = InStr(SChar + 1, Formula, "'")
Bracket = InStr(1, Formula, "]")
TabName = Mid(Formula, Bracket + 1, EChar - Bracket - 1)
Rng.Replace What:=Mid(Formula, SChar, EChar - SChar + 1), replacement:=TabName, Lookat:=xlPart
End If
Set Rng = NewSheet.Range(NewSheet.Cells.Address).Find(What:=XLMasterFileName, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False)
Wend
Set Rng = Nothing
'fix all the pivot table data sources so they point to *this* spreadsheet
'TODO: add a filter in here to remove blanks
'NOTE: do I want to add for all pivots, or only selected ones?
For Each pt In NewSheet.PivotTables
Formula = pt.PivotCache.SourceData
Bracket = InStr(1, Formula, "!")
Formula = Right(Formula, Len(Formula) - Bracket)
pt.ChangePivotCache XLClinic.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Formula)
Next
SaveNewXL NewXLName 'yes, save the spreadsheet every single time so that the links in the PPT can be updated to point to it. Sigh...
End Sub
UPDATE
Based on R3uK's suggestion, I've added a call to the beginning of the UpdateCharts Sub, here:
If Master.ChartObjects.Count > 0 Then
Set ColorWheel = New ChartColors 'only do this if we need to
End If
For Each MChart In Master.ChartObjects
If Not MChart.Chart.PivotLayout Is Nothing Then
'Re-copy just the pivot chart from Master to Clinic
CopyPivotChart PivotItemsList, MChart, CChart, Clinic
End If
With CopyPivotChart here:
Private Sub CopydPivotChart(ByVal PivotItemsList As PivotTableItems, ByVal MChart As Excel.ChartObject, ByRef CChart As Excel.ChartObject, ByRef Clinic As Worksheet)
Dim TChart As Excel.ChartObject
'Breakpoint 1
For Each TChart In Clinic.ChartObjects
If TChart.Name = MChart.Name Then
TChart.Delete
End If
Next
MChart.Chart.ChartArea.Copy
'Breakpoint 2
Clinic.PasteSpecial Format:="Microsoft Office Drawing Object", Link:=False, DisplayAsIcon:=False
Clinic.PasteSpecial Format:=2
End Sub
When I run that code, I now get
Run-time error '1004': Method 'PasteSpecial' of object'_Worksheet' failed
at the line following Breakpoint 2.
Now, if I skip the For Each loop at Breakpoint 1 (manually drag the execution point below the loop), and manually delete the chart from Worksheet Clinic, then the code executes just fine.
