Question

我有代码以预设格式自动生成大约40个图表。目前，我手动将每个图形复制并粘贴到新工作表中，不包括任何将它们分开的支持信息行。我一直在使用下面的代码自动复制和粘贴图表，但是，它将它们粘贴到与原始图纸完全相同的位置。

有没有什么方法可以压缩图表，所以它们都粘贴在一起？理想情况下，它们会粘贴在原始图纸的同一列中，只是没有任何行将它们分开。

Sub overview1()
    Dim OutSht As Worksheet
    Dim Chart As ChartObject
    Dim PlaceInRange As Range

    Set OutSht = ActiveWorkbook.Sheets("Overview_1") '<~~ Output sheet
    Set PlaceInRange = OutSht.Range("B2:J21")        '<~~ Output location

    'Loop charts
    For Each Chart In Sheets("Summary").ChartObjects
        'Copy/paste charts
        Chart.Copy
        OutSht.Paste PlaceInRange
    Next Chart

End Sub

谢谢！

编辑：感谢SørenHoltenHansen的代码。 Source

Answer 1

Sub overview1()
    Dim OutSht As Worksheet
    Dim Chart As ChartObject
    Dim PlaceInRange As Range

    Set OutSht = ActiveWorkbook.Sheets("Overview_1") '<~~ Output sheet
    Set PlaceInRange = OutSht.Range("B2:J21")        '<~~ Output location

    'Loop charts
    For Each Chart In Sheets("Summary").ChartObjects
        'Copy/paste charts
        Chart.Copy
        OutSht.Paste PlaceInRange
        'Code below changes the range itself to something 20 rows below
        Set PlaceInRange = PlaceInRange.offset(20,0)
    Next Chart

End Sub

将图表从一张纸复制到另一张

1 个答案: