VBA：ワークシート内のチャートオブジェクトの整理

Question

私はいくつかのチャートシートを持つワークブックを持っています。すべてのチャートを一度に簡単に見つけることができるシートを作成したいので、パワーポイントのプレゼンテーションにすばやくコピーして貼り付けることができます。

私のコードでは、各チャートシートのサイズをコピー、貼り付け、変更することができます。問題は、私がシートでそれらを整理しようとするときに来る。

コードはそれらをすべて1行に貼り付けています。たとえば、多数のチャートがある場合、特定のチャートを見つけるには時間がかかりすぎる可能性があります。

私は、このような何らかの形ですべての図表を整理し、各行に特定の数の図表を配置したいとします（たとえば、行ごとに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