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

Question

我在MacOS上使用Excel."左右"的信息告诉我,这是16.16.5版本,如果你的代码看这里,并认为这显然对应于2016年办"嘿,这对我的作品",这将是巨大的,如果你可以发表评论说包括您正在使用的Excel版本.

我有一个电子表格,我想将图表从"模板"工作表复制到约.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

这工作(和失败),不同于第一解决方案:它也复制图表到目标表,而不像前面的例子,可以删除使用这些图表Delete_Charts子程序.

不幸的是,这段代码失败了:

        For Each chSeries In newChartObj.Chart.SeriesCollection

错误再次是"运行时错误'1004':应用程序定义的错误或对象定义的错误".

实际上,newChartObj在那时尝试使用调试器进行检查只会导致Excel崩溃.

---

所以,我有两个部分解决方案,这两个解决方案似乎都失败的方式与我在别处看到的示例或文档不匹配.我很感激任何帮助,让其中任何一个工作.

Answer 1

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

我能够重现这个问题,下面的代码确实有效,但是我在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并且它可以工作.这只是对原始代码的轻微更改.