如何防止数据透视图成为 sheet 副本上的常规图表？
How do I prevent a PivotChart from becoming a regular chart on sheet copy?
使用 Excel 2010，我写了一些 VBA 将选定的 sheet 从主工作簿复制到客户端工作簿。该代码可以很好地将具有数据和数据关联数据透视表的数据 sheet 以及具有一个或多个数据透视图的图表 sheet 复制到新工作簿。
问题是在目标工作簿中，图表不再是数据透视图，它们是常规图表并且它们的源数据范围是空白的。主数据透视图的源数据已填写，但显示为灰色，因此不可编辑。
将工作sheet从一个工作簿复制到另一个工作簿（在这一行：XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)）后立即出现问题，但我将包括调用代码Subs.当它到达这些线时，图表已经坏了
题目分为三部分：
- 我可以防止在副本中将数据透视图转换为常规图表吗？即我错过了
.Copy 的 flag/setting 吗？
- 如果不是，我可以按照
cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable 的方式将图表再次更新为数据透视图吗？
- 如果其中任何一个都失败，在复制的作品中从头开始创建数据透视图的最佳方法是什么sheet？
注释：
- 这些是标准的 Excel 数据透视表，我没有使用 PowerPivot。不过，如果它能解决问题，我对此持开放态度。 刚刚阅读了一些关于 PowerPivot 的资料，我认为它对我没有帮助，但是，我再次愿意接受建议。
- 响应
' 评论，原始数据和数据透视表 Tables 在一个 sheet 上，数据透视表 Charts 秒 sheet.
这是代码。它适用于一切 除了 复制 sheet 数据透视图作为数据透视图完好无损。
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 的代码。它的目的是将颜色从 Master 复制到 Client worksheet，因为 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() 代码。这将根据 sheet.
中嵌入的一个或多个 SQL 查询更新 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
更新
基于 ，我在 UpdateCharts 子的开头添加了一个调用，此处：
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
当我 运行 那个代码时，我现在得到
Run-time error '1004': Method 'PasteSpecial' of object'_Worksheet' failed
在 Breakpoint 2 之后的行。
现在，如果我跳过 Breakpoint 1 处的 For Each 循环（手动将执行点拖到循环下方），并从 Worksheet 手动删除图表 Clinic, 然后代码执行得很好。
1 . 以我复制数据透视图的拙劣经验，我没有复制 Sheet 但图表 :
Sheets("Graph1").ActiveChart.ChartArea.Copy
ActiveSheet.PasteSpecial Format:="Objet Dessin Microsoft Office", _
Link:=True, DisplayAsIcon:=False
您是否尝试过创建一个空白页面并将图表粘贴到其中？
您可能需要更改法语格式，但这应该可以解决问题！[=13=]
2 . 没头绪....
3 . 为了从头开始创建一个 Pivot Table，我没有什么神奇的技巧，但我用它作为模板 :
Sub Create_DCT(ByVal Source_Table_Name As String, ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)
DeleteAndAddSheet DCT_Sheet_Name
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=Source_Table_Name, _
Version:=xlPivotTableVersion14). _
CreatePivotTable _
TableDestination:=DCT_Sheet_Name & "!R3C1", _
TableName:=DCT_Name, _
DefaultVersion:=xlPivotTableVersion14
End Sub
Sub Add_Fields_DCT(ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)
Dim Ws As Worksheet
Set Ws = Worksheets(DCT_Sheet_Name)
'Organized filters
With Ws.PivotTables(DCT_Name).PivotFields("Cluster")
.Orientation = xlPageField
.Position = 1
End With
With Ws.PivotTables(DCT_Name).PivotFields("Region")
.Orientation = xlPageField
.Position = 2
End With
With Ws.PivotTables(DCT_Name).PivotFields("Account")
.Orientation = xlPageField
.Position = 3
'Organized rows
With Ws.PivotTables(DCT_Name).PivotFields("Family")
.Orientation = xlRowField
.Position = 1
End With
With Ws.PivotTables(DCT_Name).PivotFields("Sub_family")
.Orientation = xlRowField
.Position = 2
End With
With Ws.PivotTables(DCT_Name).PivotFields("Invoice_Country")
.Orientation = xlRowField
.Position = 3
End With
With Ws.PivotTables(DCT_Name).PivotFields("Product")
.Orientation = xlRowField
.Position = 4
End With
'Columns : none
' With Ws.PivotTables(DCT_Name).PivotFields("Family")
' .Orientation = xlColumnField
' .Position = 1
' End With
'Data fields (adding, modifying, formatting and compacting)
'Data fiels : Adding
'With Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name)
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Total Qty", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Avg Qty", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Qty of Orders", xlCount
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("TotalAmountEUR"), "TO (€)", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("UPL"), "Avg UPL", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Avg Discount", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Min Discount", xlMin
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Max Discount", xlMax
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Min PVU", xlMin
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Max PVU", xlMax
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-PRI)/PVU"), "Gross Margin", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-TC)/PVU"), "Net Margin", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-PRI"), "Gross Profit (€)", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-TC"), "Net Profit (€)", xlSum
'End With
'Data fiels : Modifying
' With Ws.PivotTables(DCT_Name).PivotFields("Somme de Quantity")
' .Caption = "Moyenne de Quantity"
' .Function = xlAverage
' End With
'Data formatting
With ActiveSheet.PivotTables(DCT_Name)
.PivotFields("Total Qty").NumberFormat = "# ##0"
.PivotFields("Avg Qty").NumberFormat = "# ##0,#"
.PivotFields("Qty of Orders").NumberFormat = "# ##0"
.PivotFields("TO (€)").NumberFormat = "# ##0 €"
.PivotFields("Avg UPL").NumberFormat = "# ##0 €"
.PivotFields("Avg Discount").NumberFormat = "0,0%"
.PivotFields("Min Discount").NumberFormat = "0,0%"
.PivotFields("Max Discount").NumberFormat = "0,0%"
.PivotFields("Min PVU").NumberFormat = "# ##0 €"
.PivotFields("Max PVU").NumberFormat = "# ##0 €"
.PivotFields("Gross Margin").NumberFormat = "0,0%"
.PivotFields("Net Margin").NumberFormat = "0,0%"
.PivotFields("Gross Profit (€)").NumberFormat = "# ##0 €"
.PivotFields("Net Profit (€)").NumberFormat = "# ##0 €"
End With
'Compact row fields to minimum
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Sub_family").PivotItems
PivIt.DrillTo "Invoice_Country"
Next PivIt
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
PivIt.DrillTo "Sub_family"
Next PivIt
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
PivIt.DrillTo "Family"
Next PivIt
End Sub
还有我的自定义函数 DeleteAndAddSheet :
Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet
For Each aShe In Sheets
If aShe.Name <> SheetName Then
Else
Application.DisplayAlerts = False
aShe.Delete
Application.DisplayAlerts = True
Exit For
End If
Next aShe
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName
Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count)
End Function
希望对您有所帮助！
我建议创建第二个链接到源数据的工作簿 sheet，然后在第二个 sheet 中创建匹配的数据透视表（两者本质上都使用相同的数据来填充）——我我不确定下一点，客户是否需要图表的链接版本，或者这纯粹是为了自动报告？
如果它用于自动报告，那么我会完全建议一种新方法，使用您当前的工作簿 - 在需要时为 运行 创建一个宏，daily/weekly/monthly 等并发送图表（仅来自 sheets 你 select）作为 pdf - 如果需要，我有一些示例代码:)
如果您复制 sheet 数据和 sheet 图表 linked 到该数据，复制的图表将不会 link 到数据复制的 sheet 除非 sheet 在一次操作中一起复制。看起来您的代码首先复制 sheet 和数据透视表 table，然后单独复制 sheet 和图表（图表 sheet 或工作 sheet带有嵌入式图表，没关系）。该图表将其 link 丢失到原始工作簿中的枢轴 table，并成为具有硬编码值的常规图表。
重写您的代码以在一次操作中复制两个 sheet。然后在新工作簿中调整枢轴table和图表。
我通过使用启用 .XLTM 宏的 模板 作为实际 模板 !
解决了这个问题
我现在打开 .XLTM，删除 需要的工作表，而不是打开模板文件，然后将 需要的工作表从模板复制到新工作簿]不需要 特定客户的报告。这完全消除了复制工作表、图表和图形的需要，并消除了尝试这样做所产生的所有错误。
这并没有具体解决如何复制数据透视图而不丢失其数据透视图表的问题，但它解决了我如何实现这一目标的更大问题（我确实说过我愿意接受其他建议）。
使用 Excel 2010，我写了一些 VBA 将选定的 sheet 从主工作簿复制到客户端工作簿。该代码可以很好地将具有数据和数据关联数据透视表的数据 sheet 以及具有一个或多个数据透视图的图表 sheet 复制到新工作簿。
问题是在目标工作簿中，图表不再是数据透视图，它们是常规图表并且它们的源数据范围是空白的。主数据透视图的源数据已填写，但显示为灰色，因此不可编辑。
将工作sheet从一个工作簿复制到另一个工作簿（在这一行：XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)）后立即出现问题，但我将包括调用代码Subs.当它到达这些线时，图表已经坏了
题目分为三部分：
- 我可以防止在副本中将数据透视图转换为常规图表吗？即我错过了
.Copy的 flag/setting 吗？ - 如果不是，我可以按照
cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable的方式将图表再次更新为数据透视图吗？ - 如果其中任何一个都失败，在复制的作品中从头开始创建数据透视图的最佳方法是什么sheet？
注释：
- 这些是标准的 Excel 数据透视表，我没有使用 PowerPivot。不过，如果它能解决问题，我对此持开放态度。 刚刚阅读了一些关于 PowerPivot 的资料，我认为它对我没有帮助，但是，我再次愿意接受建议。
- 响应
这是代码。它适用于一切 除了 复制 sheet 数据透视图作为数据透视图完好无损。
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 的代码。它的目的是将颜色从 Master 复制到 Client worksheet，因为 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() 代码。这将根据 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
更新
基于 UpdateCharts 子的开头添加了一个调用，此处：
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
当我 运行 那个代码时，我现在得到
Run-time error '1004': Method 'PasteSpecial' of object'_Worksheet' failed
在 Breakpoint 2 之后的行。
现在，如果我跳过 Breakpoint 1 处的 For Each 循环（手动将执行点拖到循环下方），并从 Worksheet 手动删除图表 Clinic, 然后代码执行得很好。
1 . 以我复制数据透视图的拙劣经验，我没有复制 Sheet 但图表 :
Sheets("Graph1").ActiveChart.ChartArea.Copy
ActiveSheet.PasteSpecial Format:="Objet Dessin Microsoft Office", _
Link:=True, DisplayAsIcon:=False
您是否尝试过创建一个空白页面并将图表粘贴到其中？ 您可能需要更改法语格式，但这应该可以解决问题！[=13=]
2 . 没头绪....
3 . 为了从头开始创建一个 Pivot Table，我没有什么神奇的技巧，但我用它作为模板 :
Sub Create_DCT(ByVal Source_Table_Name As String, ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)
DeleteAndAddSheet DCT_Sheet_Name
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=Source_Table_Name, _
Version:=xlPivotTableVersion14). _
CreatePivotTable _
TableDestination:=DCT_Sheet_Name & "!R3C1", _
TableName:=DCT_Name, _
DefaultVersion:=xlPivotTableVersion14
End Sub
Sub Add_Fields_DCT(ByVal DCT_Sheet_Name As String, ByVal DCT_Name As String)
Dim Ws As Worksheet
Set Ws = Worksheets(DCT_Sheet_Name)
'Organized filters
With Ws.PivotTables(DCT_Name).PivotFields("Cluster")
.Orientation = xlPageField
.Position = 1
End With
With Ws.PivotTables(DCT_Name).PivotFields("Region")
.Orientation = xlPageField
.Position = 2
End With
With Ws.PivotTables(DCT_Name).PivotFields("Account")
.Orientation = xlPageField
.Position = 3
'Organized rows
With Ws.PivotTables(DCT_Name).PivotFields("Family")
.Orientation = xlRowField
.Position = 1
End With
With Ws.PivotTables(DCT_Name).PivotFields("Sub_family")
.Orientation = xlRowField
.Position = 2
End With
With Ws.PivotTables(DCT_Name).PivotFields("Invoice_Country")
.Orientation = xlRowField
.Position = 3
End With
With Ws.PivotTables(DCT_Name).PivotFields("Product")
.Orientation = xlRowField
.Position = 4
End With
'Columns : none
' With Ws.PivotTables(DCT_Name).PivotFields("Family")
' .Orientation = xlColumnField
' .Position = 1
' End With
'Data fields (adding, modifying, formatting and compacting)
'Data fiels : Adding
'With Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name)
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Total Qty", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Avg Qty", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Quantity"), "Qty of Orders", xlCount
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("TotalAmountEUR"), "TO (€)", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("UPL"), "Avg UPL", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Avg Discount", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Min Discount", xlMin
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("Discount"), "Max Discount", xlMax
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Min PVU", xlMin
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU"), "Max PVU", xlMax
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-PRI)/PVU"), "Gross Margin", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("(PVU-TC)/PVU"), "Net Margin", xlAverage
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-PRI"), "Gross Profit (€)", xlSum
Ws.PivotTables(DCT_Name).AddDataField Ws.PivotTables(DCT_Name).PivotFields("PVU-TC"), "Net Profit (€)", xlSum
'End With
'Data fiels : Modifying
' With Ws.PivotTables(DCT_Name).PivotFields("Somme de Quantity")
' .Caption = "Moyenne de Quantity"
' .Function = xlAverage
' End With
'Data formatting
With ActiveSheet.PivotTables(DCT_Name)
.PivotFields("Total Qty").NumberFormat = "# ##0"
.PivotFields("Avg Qty").NumberFormat = "# ##0,#"
.PivotFields("Qty of Orders").NumberFormat = "# ##0"
.PivotFields("TO (€)").NumberFormat = "# ##0 €"
.PivotFields("Avg UPL").NumberFormat = "# ##0 €"
.PivotFields("Avg Discount").NumberFormat = "0,0%"
.PivotFields("Min Discount").NumberFormat = "0,0%"
.PivotFields("Max Discount").NumberFormat = "0,0%"
.PivotFields("Min PVU").NumberFormat = "# ##0 €"
.PivotFields("Max PVU").NumberFormat = "# ##0 €"
.PivotFields("Gross Margin").NumberFormat = "0,0%"
.PivotFields("Net Margin").NumberFormat = "0,0%"
.PivotFields("Gross Profit (€)").NumberFormat = "# ##0 €"
.PivotFields("Net Profit (€)").NumberFormat = "# ##0 €"
End With
'Compact row fields to minimum
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Sub_family").PivotItems
PivIt.DrillTo "Invoice_Country"
Next PivIt
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
PivIt.DrillTo "Sub_family"
Next PivIt
For Each PivIt In ActiveSheet.PivotTables(DCT_Name).PivotFields("Family").PivotItems
PivIt.DrillTo "Family"
Next PivIt
End Sub
还有我的自定义函数 DeleteAndAddSheet :
Public Function DeleteAndAddSheet(ByVal SheetName As String) As Worksheet
For Each aShe In Sheets
If aShe.Name <> SheetName Then
Else
Application.DisplayAlerts = False
aShe.Delete
Application.DisplayAlerts = True
Exit For
End If
Next aShe
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = SheetName
Set DeleteAndAddSheet = ThisWorkbook.Worksheets(Worksheets.Count)
End Function
希望对您有所帮助！
我建议创建第二个链接到源数据的工作簿 sheet，然后在第二个 sheet 中创建匹配的数据透视表（两者本质上都使用相同的数据来填充）——我我不确定下一点，客户是否需要图表的链接版本，或者这纯粹是为了自动报告？
如果它用于自动报告，那么我会完全建议一种新方法，使用您当前的工作簿 - 在需要时为 运行 创建一个宏，daily/weekly/monthly 等并发送图表（仅来自 sheets 你 select）作为 pdf - 如果需要，我有一些示例代码:)
如果您复制 sheet 数据和 sheet 图表 linked 到该数据，复制的图表将不会 link 到数据复制的 sheet 除非 sheet 在一次操作中一起复制。看起来您的代码首先复制 sheet 和数据透视表 table，然后单独复制 sheet 和图表（图表 sheet 或工作 sheet带有嵌入式图表，没关系）。该图表将其 link 丢失到原始工作簿中的枢轴 table，并成为具有硬编码值的常规图表。
重写您的代码以在一次操作中复制两个 sheet。然后在新工作簿中调整枢轴table和图表。
我通过使用启用 .XLTM 宏的 模板 作为实际 模板 !
解决了这个问题我现在打开 .XLTM，删除 需要的工作表，而不是打开模板文件，然后将 需要的工作表从模板复制到新工作簿]不需要 特定客户的报告。这完全消除了复制工作表、图表和图形的需要，并消除了尝试这样做所产生的所有错误。
这并没有具体解决如何复制数据透视图而不丢失其数据透视图表的问题，但它解决了我如何实现这一目标的更大问题（我确实说过我愿意接受其他建议）。