Question

我在MacOS上使用Excel。 “关于”信息告诉我它是版本16.16.5，显然对应于Office2016。如果您在此处查看代码并认为“嘿，对我有用”，那么可以留下评论包括您正在使用的Excel版本。

我有一个电子表格，我想在其中将图表从“模板”工作表复制到大约1。其他80个工作表，然后修改它们以引用目标表而不是原始表上的数据（通过在该系列上进行简单的搜索和替换）。

乍一看似乎并不那么困难，并且在Stack Overflow和其他地方都有很多潜在的解决方案，但我似乎总是遇到意想不到的行为。

对于下面的示例，代码仅将图表从一个工作表复制到另一个工作表，而不是遍历所有可用的工作表，因为这样做会使失败时的清理更加容易。到目前为止，始终如此。

尝试＃1

我的第一次尝试是这样的：

Sub Copy_Charts()
  Dim DataSheetName1 As String, DataSheetName2 As String
  Dim chartObj as ChartObject, chartObjCopy as ChartObject
  Dim sourceChartSheet as Worksheet, destChartSheet as Worksheet

  DataSheetName1 = "CU-2"
  DataSheetName2 = "CU-8"

  Set sourceChartSheet = Sheets(DataSheetName1)
  Set destChartSheet = Sheets(DataSheetName2)

  For Each chartObj In sourceChartSheet.ChartObjects

          chartObj.Copy
          destChartSheet.Range(chartObj.TopLeftCell.Address).PasteSpecial xlPasteAll
          chartIndex = chartIndex + 1
          Set chartObjCopy = destChartSheet.ChartObjects(chartIndex)
          chartObjCopy.Left = chartObj.Left
          chartObjCopy.Top = chartObj.Top
  Next chartObj

End Sub

这几乎可行：实际上确实将图表复制到目标工作表。但是，它在此行失败：

        Set chartObjCopy = destChartSheet.ChartObjects(chartIndex)

错误是“运行时错误'1004'：应用程序定义的错误或对象定义的错误”。

实际上，如果您此时查看destChartSheet.ChartObjects.Count，它仍显示为0。此外，如果您尝试使用以下代码删除图表：

Sub Delete_Charts()
  Dim sht As Worksheet

  For Each sht In ActiveWorkbook.Worksheets
      If sht.Name <> "CU-2" Then
      If sht.ChartObjects.Count >= 1 Then
              sht.ChartObjects.Delete
              End If
      End If
  Next sht
End Sub

它实际上不会删除图表。如果您手动复制和粘贴图表，则相同的删除代码也可以正常工作。

总而言之：此代码确实复制了图表，但是我无法获得对该副本的引用以进行修改，也无法删除它。

尝试＃2

我决定将复制粘贴粘贴到窗口之外，然后尝试使用Duplicate方法。我结束了以下内容：

Sub Copy_Charts()
    Dim DataSheetName1 As String, DataSheetName2 As String
    Dim sourceChartSheet As Worksheet, destChartSheet As Worksheet
    Dim chartObj As ChartObject, newChartObj As ChartObject
    Dim chartObjCopy As ChartObject
    Dim chSeries As Series
    Dim chartIndex As Integer

    DataSheetName1 = "CU-2"
    DataSheetName2 = "CU-8"

    Set sourceChartSheet = Sheets("CU-2")
    Set destChartSheet = Sheets("CU-8")

    For Each chartObj In sourceChartSheet.ChartObjects
        ' No idea why chartObj.Duplicate returns something other
        ' than a ChartObject.
        Set newChartObj = chartObj.Duplicate.Chart.Parent
        newChartObj.Top = chartObj.Top
        newChartObj.Left = chartObj.Left
        newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

        For Each chSeries In newChartObj.Chart.SeriesCollection
            chSeries.FormulaR1C1 = Replace(chSeries.FormulaR1C1, DataSheetName1, DataSheetName2)
        Next

    Next chartObj

End Sub

这与第一个解决方案不同（但失败）：它也将图表复制到目标工作表中，并且与之前的示例不同，可以使用{{1}删除这些图表}子例程。

不幸的是，此代码在以下位置失败：

Delete_Charts

错误再次为“运行时错误'1004'：应用程序定义的错误或对象定义的错误”。

实际上，此时尝试使用调试器检查For Each chSeries In newChartObj.Chart.SeriesCollection只会使Excel崩溃。

因此，我有两个部分解决方案，它们都似乎在某种程度上与我在其他地方看到的示例或文档不匹配。如果能使其中任何一个都起作用，我将不胜感激。

Answer 1

我认为，当移动图表位置时，将更改对图表对象的引用，从而导致Series Collection失败。

我能够重现该问题，并且下面的代码可以工作，但是我在PC上，因此如果要在Mac上启动和运行需要进行进一步的更改，我不是100％。如果您移动此行：

newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

在SeriesCollection循环之后有效，但在之前无效。

Option Explicit

Sub Copy_Charts()
    Dim DataSheetName1 As String, DataSheetName2 As String
    Dim sourceChartSheet As Worksheet, destChartSheet As Worksheet
    Dim chartObj As ChartObject, newChartObj As ChartObject
    Dim chartObjCopy As ChartObject
    Dim chSeries As Series

    DataSheetName1 = "CU-2"
    DataSheetName2 = "CU-8"

    Set sourceChartSheet = ThisWorkbook.Sheets(DataSheetName1)
    Set destChartSheet = ThisWorkbook.Sheets(DataSheetName2)

    For Each chartObj In sourceChartSheet.ChartObjects
         Set newChartObj = chartObj.Duplicate.Chart.Parent
        'Set newChartObj = chartObj 'Reference the sheet, good if you are cut/pasting the chart

        For Each chSeries In newChartObj.Chart.SeriesCollection
            chSeries.FormulaR1C1 = Replace(chSeries.FormulaR1C1, DataSheetName1, DataSheetName2)
        Next

        newChartObj.Top = chartObj.Top
        newChartObj.Left = chartObj.Left

        'Move this after the SeriesCollection loop
        newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name
    Next

End Sub

Answer 2

Sub Copy_Charts()


    Dim DataSheetName1 As String, DataSheetName2 As String
    Dim sourceChartSheet As Worksheet, destChartSheet As Worksheet
    Dim chartObj As ChartObject, newChartObj As ChartObject
    Dim chartObjCopy As ChartObject
    Dim chSeries As Series
    Dim chartIndex As Integer

    DataSheetName1 = "CU-2"
    DataSheetName2 = "CU-8"

    Set sourceChartSheet = Sheets("CU-2")
    Set destChartSheet = Sheets("CU-8")

    For Each chartObj In sourceChartSheet.ChartObjects
        ' No idea why chartObj.Duplicate returns something other
        ' than a ChartObject.
        Set newChartObj = chartObj.Duplicate.Chart.Parent
        newChartObj.Top = chartObj.Top
        newChartObj.Left = chartObj.Left
        newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

        'For Each chSeries In newChartObj.Chart.SeriesCollection
        '    chSeries.FormulaR1C1 = Replace(chSeries.FormulaR1C1, DataSheetName1, DataSheetName2)
        'Next

    Next chartObj

    For Each chartObj In destChartSheet.ChartObjects
        For Each chSeries In chartObj.Chart.SeriesCollection:
            chSeries.FormulaR1C1 = Replace(chSeries.FormulaR1C1, DataSheetName1, DataSheetName2)
        Next
    Next chartObj

End Sub

我在Mac，Excel：16.20上对其进行了测试，并且可以正常工作。只是您的原始代码略有更改。

Answer 3

我无权使用Mac，因此我不得不在Windows 10，Office 2016上对其进行测试，但我可以重现该错误。关于您的尝试2，我发现问题是由以下几行引起的：

newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

它有一个副作用：当原始对象（引用）将变得无效时，将创建一个新图表，因此，当您尝试访问其SeriesCollection属性时会收到错误消息。但是，Location函数会返回对新图表的引用，因此您只需更新newChartObj即可引用新图表（而不是将上面的代码放在代码中）：

Set newChartObj = newChartObj.Chart.Location(xlLocationAsObject, destChartSheet.Name).Parent

Answer 4

尝试

Sub Copy_Charts()
  Dim DataSheetName1 As String, DataSheetName2 As String
  Dim chartObj As ChartObject, chartObjCopy As ChartObject
  Dim sourceChartSheet As Worksheet, destChartSheet As Worksheet

  DataSheetName1 = "CU-2"
  DataSheetName2 = "CU-8"

  Set sourceChartSheet = Sheets(DataSheetName1)
  Set destChartSheet = Sheets(DataSheetName2)

  For Each chartObj In sourceChartSheet.ChartObjects

          chartObj.Copy
          destChartSheet.Paste
          'destChartSheet.Range(chartObj.TopLeftCell.Address).PasteSpecial xlPasteAll
          chartIndex = chartIndex + 1
          Set chartObjCopy = destChartSheet.ChartObjects(chartIndex)
          chartObjCopy.Left = chartObj.Left
          chartObjCopy.Top = chartObj.Top
  Next chartObj

End Sub

使用VBA复制图表：无法删除或无法修改副本

尝试＃1

尝试＃2

4 个答案: