Используя Excel 2010, я написал несколько VBA, чтобы скопировать выбранные листы из основной книги в рабочую книгу клиента. Код работает очень хорошо, чтобы скопировать лист данных с данными и сводной таблицей (-ами), связанными с данными, и лист диаграммы с одним или несколькими PivotCharts в новую книгу.
Проблема в том, что в рабочей книге назначения диаграммы больше не являются PivotCharts, они являются регулярными диаграммами, а их исходный диапазон данных пуст. Исходные данные для Master PivotChart заполнены, но выделены серым цветом, поэтому они не редактируются.
Проблема появляется сразу после копирования листа из одной книги в другую (в этой строке: XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)), хотя я буду включать код для вызова Subs. К тому времени, когда он дойдет до этих строк, график уже сломан.
Вопрос состоит из трех частей:
- Могу ли я предотвратить преобразование PivotChart в обычный график в копии? т.е. существует ли флаг/параметр для
.Copy, который я пропустил? - Если нет, могу ли я обновить диаграмму как PivotChart снова чем-то вдоль строк
cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable? - Неудача любого из них, что лучший способ создать PivotChart с нуля в скопированном листе?
ПРИМЕЧАНИЯ:
- Это стандартные сводные таблицы Excel, я не использую PowerPivot. Однако я открыт для этого, если это исправит проблему. Сделав небольшое чтение на PowerPivot, я не думаю, что это поможет мне, но, опять же, я открыт для предложений.
- В ответ на комментарий Jens, исходные данные и сводные таблицы находятся на одном листе, а сводные диаграммы находятся на втором листе.
Вот код. Он отлично работает для всего, кроме копирования листа с PivotChart без изменений в качестве 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
Вот код для UpdateCharts. Его цель - скопировать цвета с листа "Мастер" на "Клиент", поскольку Excel, похоже, предпочитает назначать случайные цвета для новых диаграмм.
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
Вот код ProcessDataSheet(). Это обновит данные на листе на основе одного или нескольких SQL-запросов, встроенных в лист.
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
Основываясь на предложении R3uK, я добавил вызов в начало UpdateCharts Sub, здесь:
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
С CopyPivotChart здесь:
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
Когда я запустил этот код, теперь я получаю
Ошибка времени выполнения "1004": не удалось выполнить метод "PasteSpecial" объекта "Рабочий лист"
в строке, следующей за Breakpoint 2.
Теперь, если я пропущу цикл For Each в Breakpoint 1 (вручную перетащите точку выполнения ниже цикла) и вручную удалите диаграмму из Worksheet Clinic, тогда код будет выполнен просто отлично.