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

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

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

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

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

在Cell 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

VBA：在工作表

2 个答案: