如何防止数据透视图成为工作表副本上的常规图表？

Posted

技术标签:

【中文标题】如何防止数据透视图成为工作表副本上的常规图表？【英文标题】：How do I prevent a PivotChart from becoming a regular chart on sheet copy? 【发布时间】：2015-06-19 01:58:41 【问题描述】：

使用 Excel 2010，我编写了一些 VBA 来将选定的工作表从主工作簿复制到客户端工作簿。该代码可以很好地将具有与数据关联的数据和数据透视表的数据表以及具有一个或多个数据透视图的图表表复制到新工作簿。

问题在于，在目标工作簿中，图表不再是数据透视图，而是常规图表，并且其源数据范围为空白。主数据透视图的源数据已填写，但显示为灰色，因此不可编辑。

将工作表从一个工作簿复制到另一个工作簿后，问题立即出现（在此行：XLMaster.Sheets(SlideRS.Fields(2).Value).Copy After:=XLClinic.Sheets(XLClinic.Sheets.Count)），但我将包含调用Subs 的代码。当它到达这些线时，图表已经坏了

问题分三部分：

    我可以防止数据透视图在副本中转换为常规图表吗？即我错过了.Copy 的标志/设置吗？ 如果不是，我可以按照cchart.Chart.PivotLayout.PivotTable = mchart.Chart.PivotLayout.PivotTable 的方式再次将图表更新为数据透视图吗？ 如果其中任何一个都失败，在复制的工作表中从头开始创建数据透视图的最佳方法是什么？

注意事项：

    这些是标准的 Excel 数据透视表，我没有使用 PowerPivot。不过，如果它可以解决问题，我对此持开放态度。 刚刚对 PowerPivot 进行了一些阅读，我认为它对我没有帮助，但是，再次，我愿意接受建议。 作为对Jens'评论的回应，原始数据和数据透视表在一张纸上，而数据透视图表在第二张纸上。

这是代码。它非常适用于除了将带有完整数据透视图的工作表复制为数据透视图。

  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

更新

基于R3uK's suggestion，我在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”：对象“_Worksheet”的方法“PasteSpecial”失败

在Breakpoint 2 之后的行。

现在，如果我跳过Breakpoint 1 处的For Each 循环（手动将执行点拖到循环下方），并从Worksheet Clinic 中手动删除图表，则代码执行得很好。

【问题讨论】：

我似乎无法复制您的问题。当我将包含数据透视图的工作表复制到带有Excel.ActiveWorkbook.Sheets("SheetX").Copy 的新工作簿时，它也会复制源数据，并且仍然是数据透视图。我在这里错过了什么吗？ 很好的问题，@Jens，似乎我遗漏了一个重要且明显（但仅对我而言）的细节。 Source.Sheets("Sheet1") 包含原始数据和轴 Tables，Source.Sheets("Sheet2") 包含轴 Charts。 ProcessDataSheet() 中的中间 While 循环用于更新“Sheet1”上的数据透视表，因此它们指向 Destination.("Sheets1")，并且效果很好。 嗨，FreeMan...您可以在某处上传样本，然后提供指向您的样本的链接吗？ 这是所有健康信息，@Davesexcel，因此需要大量重新创建数据来制作不会违反HIPPA 的样本。我会在星期一看看我是否可以创造一些东西...... 【参考方案1】：

1 .在我复制数据透视图的卑微经验中，我没有复制工作表而是复制图表：

Sheets("Graph1").ActiveChart.ChartArea.Copy
ActiveSheet.PasteSpecial Format:="Objet Dessin Microsoft Office", _
    Link:=True, DisplayAsIcon:=False

您是否尝试过创建一个空白页面并将图表粘贴到其中？ 您可能必须更改法语的格式，但这应该可以解决问题！

2 .没有线索....

3 . 对于从头开始创建数据透视表，我没有什么神奇的技巧，但我将其用作模板：

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

希望对你有帮助！

【讨论】：

好的，这已经酝酿了一段时间。尝试了您的建议＃1。我喜欢它，但是我不能保证工作表上的所有图表都是数据透视图，并且许多工作表都有一些用于图表的数据，或者就像最终被复制的 PPT 中一样到，所以... 我的目标是 1）复制工作表，2）删除数据透视图，如果它存在，3）从主复制数据透视图。如果我手动执行第 2 步（在调试中），这将非常有用。如果我让代码循环遍历所有图表以按名称从 dest 表中删除，它会失败并显示 err 1004 Method PasteSpecial of object _Worksheet failed。 一点点东西（该睡觉了；）），你试过ByVal ClinicCopydPivotChart吗？我会在几个小时内仔细查看它，因为它是如此接近！ 必须是ByRef。 Clinic 是目标工作表 - 它是新图表需要去的地方！ 我在这里提供赏金，因为我相信建议 #1 是正确的道路。只有一些小问题需要解决，我会很高兴的。谢谢你的帮助，R3uK！！ 对此的新答案提醒我跟进。我已将我的工作结果发布为已接受的答案。不知道您是否已经设法通过最少的桌面接口来完成您的任务，但我的解决方案可能对您有用，我想引起您的注意。希望一切顺利，再次感谢您的帮助！【参考方案2】：

我建议创建一个链接到源数据表的第二个工作簿，然后在第二个表中创建匹配的数据透视表（两者本质上都使用相同的数据来填充）——我不确定下一点，是客户需要图表的链接版本还是纯粹用于自动报告？

如果是用于自动报告，那么我建议完全采用一种新方法，使用您拥有的当前工作簿 - 创建一个宏以在需要时按时、每天/每周/每月等运行并发送图表（从您的工作表中仅选择）作为 pdf - 如果需要，我有一些示例代码 :)

【讨论】：

【参考方案3】：

我通过使用启用 .XLTM 宏的 模板 作为实际的 模板 解决了这个问题！

我现在不是打开模板文件然后将需要的工作表从模板复制到新工作簿，而是打开 .XLTM，删除不需要的工作表 需要特定客户的报告。这完全消除了复制工作表、图表和图形的需要，并消除了尝试这样做所产生的所有错误。

这并没有具体解决 如何 复制透视图而不丢失其透视图的问题，但它解决了我如何实现这一点的大局问题（我确实说过我愿意接受其他建议）。

【讨论】：

感谢您的意见，事实上，替代方法通常是最好的！^^ 尤其是当它需要较少繁重的工作时！【参考方案4】：

如果您复制包含数据的工作表和包含链接到该数据的图表的工作表，则复制的图表将不会链接到复制的工作表上的数据，除非在一次操作中将工作表一起复制。看起来您的代码首先使用数据透视表复制工作表，然后单独复制带有图表的工作表（图表工作表或带有嵌入图表的工作表，没关系）。该图表失去了与原始工作簿中数据透视表的链接，并成为具有硬编码值的常规图表。

重写代码以在一次操作中复制两张表。然后在新工作簿中调整数据透视表和图表。

【讨论】：

感谢您的想法，乔恩。不过，我不久前解决了这个问题，但你确实提示我发布最终成为我工作解决方案的内容。

以上是关于如何防止数据透视图成为工作表副本上的常规图表？的主要内容，如果未能解决你的问题，请参考以下文章

excel数据透视表如何生成柱状图表

图表的 SetSourceData 为数据透视表返回 HRESULT E_FAIL (Excel C#)

2022年最新Python大数据之Excel基础

将处理后的数据用数据透视表 生成有价值的图表

防止 Laravel 向数据透视表添加多条记录

如何防止工作表在 SwiftUI 中使其后面的视图变暗或删除不必要的填充？