VBA：在工作表中组织图表对象

Question

我有一个包含多个图表的工作簿。我想创建一个表格，可以在其中轻松找到所有图表，以便我可以快速复制它们，然后将它们粘贴到 PowerPoint 演示文稿中。

我的代码可以很好地复制、粘贴和更改每个图表的大小。当我试图在工作表中组织它们时，麻烦就来了。

问题是代码将它们全部粘贴在一行中。例如，如果我有大量图表，找到一个特定的图表可能会花费太多时间。

我想以这种方式组织所有图表，为每行设置特定数量的图表（例如，每行 2 个图表）。

我尝试将.left 属性用于图表，但它会将所有图表对齐到同一列（请注意，这不是我的意图）。

我也尝试为行引入一个变量，但我无法控制该变量何时应该“跳转”到下一行以粘贴图表。

如果可行，有什么想法吗？

Sub PasteCharts()

Dim wb As Workbook
Dim ws As Worksheet
Dim Cht As Chart
Dim Cht_ob As ChartObject

Set wb = ActiveWorkbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


'k is the column number for the address where the chart is to be pasted
k = -1
For Each Cht In wb.Charts

    k = k + 1
    Cht.Activate
    ActiveChart.ChartArea.Select
    ActiveChart.ChartArea.Copy

    Sheets("Gráficos").Select
    Cells(2, (k * 10) + 1).Select
    ActiveSheet.Paste

Next Cht


'Changes the size of each chart pasted in the specific sheet
For Each Cht_ob In Sheets("Gráficos").ChartObjects
With Cht_ob
    .Height = 453.5433070866
    .Width = 453.5433070866

End With

Next Cht_ob


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


MsgBox ("All Charts were pasted successfully")
End Sub

Answer 1

试试下面的代码，它将复制>>将工作簿中的所有图表粘贴到“Gráficos”工作表中。

目前会在A列粘贴奇数图，在K列粘贴偶数图（可以在代码中轻松修改）。

每2个图表之间的间隔为30行（也可以在下面的代码中修改）。

要将图表放置在某个单元格中，您需要使用ChartObject 并使用它的.Top 和.Left 属性。

在单元格 A1 中放置图表的语法是：

Cht_ob.Top = Sheets("Charts").Range("A1").Top

代码

Option Explicit

Sub PasteCharts()

Dim wb As Workbook
Dim ws As Worksheet
Dim Cht As Chart
Dim Cht_ob As ChartObject
Dim k As Long
Dim ChartRowCount As Long

Set wb = ActiveWorkbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

k = 0 ' row number, increment every other 2 charts
ChartRowCount = 1 ' column number, either 1 or 2
For Each Cht In wb.Charts
    Cht.ChartArea.Copy ' copy chart        
    Sheets("Gráficos").Paste ' paste chart

    Set Cht_ob = Sheets("Gráficos").ChartObjects(Sheets("Charts").ChartObjects.Count)  ' set chart object to pasted chart

    With Cht_ob
        If ChartRowCount = 1 Then
            .Top = Sheets("Gráficos").Range("A" & 1 + 30 * k).Top ' modify the top position
            .Left = Sheets("Gráficos").Range("A" & 1 + 30 * k).Left ' modify the left position

            ChartRowCount = ChartRowCount + 1
        Else ' ChartRowCount = 2
            .Top = Sheets("Gráficos").Range("K" & 1 + 30 * k).Top ' modify the top position
            .Left = Sheets("Gráficos").Range("K" & 1 + 30 * k).Left  ' modify the left position

            ChartRowCount = 1
            k = k + 1
        End If

        .Height = 453.5433070866
        .Width = 453.5433070866
    End With
Next Cht

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox ("All Charts were pasted successfully")

End Sub

Answer 2

我建议另一种直接在坐标上而不是在单元格上进行的方法：

Sub PasteCharts()
    Dim cht As Chart, cht_ob As ChartObject, left As Long, top As Long
    Dim chartWidth As Long, chartHeight As Long, chartsPerRow As Long
    chartWidth = 200: chartHeight = 200: chartsPerRow = 4  ' <-- Set to your choice

    Application.ScreenUpdating = False: Application.EnableEvents = False
    On Error GoTo Cleanup
    For Each cht In ThisWorkbook.Charts
        Set cht_ob = Worksheets("Gráficos").ChartObjects.Add(left, top, chartWidth, chartHeight)
        cht.ChartArea.Copy
        cht_ob.Chart.Paste

        'adjust coordinates for next  chart object
        left = left + chartWidth
        If left > chartsPerRow * chartWidth * 0.99 Then
            left = 0
            top = top + chartHeight
        End If
    Next
    msgBox ("All Charts were pasted successfully")
Cleanup:
    Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub