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

我有一本有几张图表的工作簿。我想创建一个工作表，在其中可以一次轻松找到所有图表，以便快速复制并粘贴到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

---

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

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

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

要在特定单元格中放置图表，需要使用

ChartObject

并使用它的

.Top

和

.Left

属性

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

Cht_ob.Top=图纸（“图表”）范围（“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

---

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

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

子图表（）
将海隧变暗为图表，海隧ob变为图表对象，左侧变长，顶部变长
调暗图表宽度等于长，图表高度等于长，图表箭头等于长
chartWidth=200:chartHeight=200:chartsPerRow=4'您的原始图表都在哪里？在工作簿中的多个工作表中？在一张纸上？或作为图表页放置？原始的所有图表都作为图表页放置在同一工作簿中。您是否尝试过以下解决方案？有任何反馈吗？两种解决方案都非常有效！我们同时在做：）。好吧，两者都应该起作用，我的建议是设置坐标，而不是使用单元格。