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

我有一个工作簿几张图表。 我想创build一个表格，可以一次很容易地find所有的图表，所以我可以快速复制，然后粘贴到PowerPoint演示文稿。

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

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

我想组织所有的图表，为每一行分配一定数量的图表（比如说，每行2个图表）。

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

我也试图为行引入一个variables，但是我无法控制variables何时应该跳转到下一行来粘贴图表。

任何想法，如果这是可行的？

 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列中的偶数图表（您可以在代码中轻松修改）。

每两个图表之间的差距是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

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

 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