代码之家  ›  专栏  ›  技术社区  ›  larsks

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

macos vba excel
  •  4
  • larsks  · 技术社区  · 7 年前

    我在MacOS上使用Excel。“关于”信息告诉我它是16.16.5版,显然对应于Office2016。如果你看这里的代码并认为“嘿,这对我很有用”,你可以留下一个包含你正在使用的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

    这几乎是可行的:它确实将图表复制到目标工作表。但是,它在这一行失败: 

            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崩溃。

    所以,我有两个部分解决方案,这两个方案似乎都失败了,它们与我在其他地方看到的示例或文档不匹配。如果能帮上忙,我将不胜感激。

    4 回复  |  直到 7 年前
        1
  •  5
  •   Ryan Wildry    7 年前

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

    我能够重现这个问题,下面的代码确实有效,但是我在个人电脑上,所以如果需要任何进一步的更改来启动和运行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
        2
  •  5
  •   xudesheng    7 年前 
    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上测试了它,它工作了。这只是你原始代码的一个微小变化。

        3
  •  2
  •   z32a7ul    7 年前

    我没有访问Mac的权限,所以我必须在Windows10,Office2016上测试它,但我可以复制错误。 关于您的尝试2,我发现问题是由以下行引起的: 

    newChartObj.Chart.Location xlLocationAsObject, destChartSheet.Name

    它有一个副作用:将创建一个新图表,而原始对象(引用)将变为无效,因此当您尝试访问其SerieScollection属性时,将收到一个错误。但是,location函数返回对新图表的引用,因此您只需更新newchartobj以引用新图表(而不是在代码中使用上面的行): 

    Set newChartObj = newChartObj.Chart.Location(xlLocationAsObject, destChartSheet.Name).Parent
        4
  •  0
  •   Dy.Lee    7 年前

    尝试 

    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
    推荐文章
    关于   移动版
    代码之家 - 一站式码农服务社区
    沪ICP备11025650号