Excel 使用VBA复制图表：可以'；t删除或可以'；不要修改副本

我正在MacOS上使用Excel。“关于”信息告诉我它是版本16.16.5，显然对应于Office 2016。如果您看到这里的代码并认为“嘿，这对我很有用”，那么如果您能留下一条评论，其中包含您正在使用的Excel版本，那将是一件非常棒的事情

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

乍一看，这并没有那么困难，在堆栈溢出和其他方面都有很多潜在的解决方案，但我似乎一直遇到意想不到的行为

对于下面的示例，代码只是将图表从一个工作表复制到另一个工作表，而不是遍历所有可用的工作表，因为这样在失败时更容易清理。到目前为止，这一直是个问题

尝试#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

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

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

        Set chartObjCopy = destChartSheet.ChartObjects(chartIndex)

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

事实上，如果此时查看destChartSheet.ChartObjects.Count，它仍然显示为

0

。此外，如果您尝试使用以下代码删除图表：

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

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

这与第一个解决方案的工作方式（和失败方式）不同：它还将图表复制到目标工作表中，与前面的示例不同，可以使用

delete\u charts

子例程删除这些图表

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

        For Each chSeries In newChartObj.Chart.SeriesCollection

错误再次是“运行时错误‘1004’：应用程序定义的错误或对象定义的错误”

事实上，尝试在此时使用调试器检查

newChartObj

只会使Excel崩溃

---

---

因此，我有两个部分解决方案，这两个方案似乎都失败了，与我在其他地方看到的示例或文档不匹配。如果您能帮助我使其中任何一个正常工作，我将不胜感激。

我认为当移动图表位置时，会更改对图表对象的引用，从而导致系列集合失败

我能够重现这个问题，下面的代码确实有效，但是我在PC机上，所以如果需要在Mac上启动和运行任何进一步的更改，我不是100%。如果移动此行：

        Set chartObjCopy = destChartSheet.ChartObjects(chartIndex)

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

---

我在我的Mac电脑上测试了它，Excel:16.20，它运行正常。这只是对您的原始代码的一个微小更改。

我没有访问Mac的权限，因此我必须在Windows 10 Office 2016上测试它，但我可以重现错误。 关于您的尝试#2，我发现问题是由以下几行引起的：

newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

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

试一试

---

谢谢我有一个问题：您正在设置

newChartObj=chartObj

。在我看来，你只是得到了原始图表的第二个参考，因此在接下来的几行中，你只是修改了原始图表，而从不复制。我误读了吗？是的，没错。我误解了你的要求，如果你想要一份副本，请参阅编辑。@z32a7ul的回答（）解释了为什么在更新

Location

属性后事情不起作用。创建新的图表对象对你有用吗？根据源工作表中的数据在目标工作表中创建新图表会更容易。您的意思是通过VBA创建新图表？从长远来看，这可能是一个更好的解决方案，但现在复制图表可以让我们更好地控制它们的外观，而不必学习如何通过VBA完成所有这些。但这是我们考虑过的：）。谢谢你的解释！我没想到更改位置会创建一个新对象；这种行为似乎不是。

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