VBA: Organisieren von Diagrammobjekten in Arbeitsblatt

Question

Ich habe eine Arbeitsmappe mit mehreren Diagrammblättern. Ich möchte ein Blatt erstellen, auf dem alle Diagramme auf einmal leicht gefunden werden können. So kann ich sie schnell kopieren und in Powerpoint-Präsentationen einfügen.

Mein Code kann die Größe jedes Diagrammblattes kopieren, einfügen und ändern. Das Problem kommt, wenn ich versuche, sie auf dem Blatt zu organisieren.

Die Sache ist, dass der Code sie alle in einer einzigen Zeile fügt. Wenn ich zum Beispiel eine große Anzahl von Diagrammen habe, könnte das Finden eines bestimmten Charakters zu viel Zeit in Anspruch nehmen.

Ich möchte alle Diagramme in etwas dieser Art organisieren, eine bestimmte Anzahl von Diagrammen für jede Zeile (sagen wir zum Beispiel, 2 Diagramme pro Zeile).

Ich versuchte, die .left Eigenschaft für Diagramme zu verwenden, aber es richtet alle Diagramme der gleichen Spalte (und bitte beachten Sie, dass dies nicht meine Absicht ist).

Ich habe auch versucht, eine Variable für die Zeilen einzuführen, aber ich habe Probleme bei der Kontrolle, wenn die Variable für die nächste Zeile "springen" soll, um das Diagramm einzufügen.

Irgendwelche Ideen, wenn dies machbar ist?

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

Probieren Sie den Code unten, es wird kopieren >> fügen Sie alle Diagramme in Ihrer Arbeitsmappe auf "Gráficos" Blatt.

Momentan werden die ungeraden Diagramme in Spalte A und die geraden Diagramme in Spalte K eingefügt (Sie können dies einfach im Code ändern).

Der Abstand zwischen den beiden Diagrammen beträgt 30 Zeilen (kann auch im folgenden Code geändert werden).

Um ein Diagramm in eine bestimmte Zelle zu platzieren, müssen Sie ChartObject verwenden und .Top und .Left Eigenschaften verwenden.

Die Syntax ein Diagramm in der Zelle A1 zu platzieren ist:

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

-Code

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

I ein weiteres Verfahren vorzuschlagen, die direkt auf den Koordinaten, nicht auf den Zellen verläuft:

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