Excel Chart per Makro

Sub KreisChart() Range("T5:X5").Select Charts.Add ActiveChart.ChartType = xlPie ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range("T5:X5"), PlotBy _ :=xlRows ActiveChart.SeriesCollection(1).XValues = "=Tabelle1!R3C21:R3C24" ActiveChart.SeriesCollection(1).Values = "=Tabelle1!R5C21:R5C24" ActiveChart.SeriesCollection(1).Name = "=Tabelle1!R5C4" ActiveChart.Location Where:=xlLocationAsObject, Name:="Tabelle1" Windows("Test.xls").SmallScroll ToRight:=-1 ActiveChart.SetSourceData Source:=Sheets("Tabelle1").Range( _ "D3,T3:X3,D5,T5:X5"), PlotBy:=xlRows ActiveWindow.Visible = False Windows("Test.xls").Activate Range("Y8").Select End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michi,
nach etwas Probiererei für das Positionieren der Charts hat es endlich geklappt.
Falls das Makro mehrmals nacheinander ausgeführt wird, dann gibt es einen Speicherüberlauf und das Makro bricht mit Fehlermeldung ab.
Wenn du das Makro ausprobierst also nach ca. 4 Makrodurchläufen die Datei speichern, schließen und wieder öffnen.
Prüfe noch einmal die gewählten Datenbereiche. Ich hab mich an den Spalten orientiert, die Du für die SeriesCollection angegeben hast.
Gruss
Franz


Sub KreisChart()
Dim Bereich As Range, I As Integer, wks As Worksheet, Diag As Chart
Set wks = Sheets("Tabelle1")
With wks
Application.ScreenUpdating = False
Call KreisChartsLoeschen 'Löscht die vorhandenen Kreischarts
For I = 1 To 25
'Datenbereich selektieren
Set Bereich = .Range("D3,U3:X3")
Set Bereich = Union(Bereich, .Cells(5 + I - 1, 4), .Range(.Cells(5 + I - 1, 21), .Cells(5 + I - 1, 24)))
Bereich.Select
'Diagramm einfügen
Charts.Add
Set Diag = ActiveChart
With Diag
.ChartType = xlPie
.SetSourceData Source:=Bereich, PlotBy:=xlRows
.SeriesCollection(1).XValues = "=" & wks.Name & "!R3C21:R3C24"
.SeriesCollection(1).Values = "=" & wks.Name & "!R" & 5 + I - 1 & "C21:R" & 5 + I - 1 & "C24"
.SeriesCollection(1).Name = "=" & wks.Name & "!R" & 5 + I - 1 & "C4"
.Location Where:=xlLocationAsObject, Name:=wks.Name
End With
'Diagramm benamen
.ChartObjects(I).Name = "KreisDiagramm" & I
'Diagramm positionieren Zeile
' 30 ist gleich obere Zeile des 1. Diagramms, 18 = Zeilenabstand der Diagramme
.Shapes("KreisDiagramm" & I).Top = wks.Cells(30 + Int((I - 1) / 2) * 18, 1).Top
'Diagramm positionieren Spalte es werden immer 2 Diagramme nebeneinander plaziert
Select Case I Mod 2
Case 0
'7 = 2. Diagramm wird links in Spalte 7 positioniert
.Shapes("KreisDiagramm" & I).Left = wks.Cells(1, 7).Left
Case 1
'1 = 1. Diagramm wird links in Spalte 1 positioniert
.Shapes("KreisDiagramm" & I).Left = wks.Cells(1, 1).Left + 1
Case Else
'do nothing
End Select
Next
.Range("A29").Select
End With
Application.ScreenUpdating = True
End Sub
Sub KreisChartsLoeschen()
'Löscht die vom Makro im vorherigen Durchlauf erzeugten Kreisdiagramme
Dim wks As Worksheet, Diag As ChartObject
Set wks = Sheets("Tabelle1")
For Each Diag In wks.ChartObjects
If Left(Diag.Name, 13) = "KreisDiagramm" Then
Diag.Delete
End If
Next
End Sub
Sub ChartsLoeschen()
'Löscht alle Chart-Objekte im Aktiven Blatt
Dim wks As Worksheet
Set wks = ActiveSheet
wks.ChartObjects.Delete
End Sub

Beliebteste Forumthreads (12 Monate)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread