AW: VBA: Einfügen von Diagrammen automatisieren
18.07.2015 10:44:47
Diagrammen
Hallo Jason,
ich hab deine Datei unter Excel 2010 (Version 14.0.7151.5001 (32 bit)), Windows Vista getestet.
Ich hatte 2 Probleme nachdem ich das 1. Diagramm als Diagramm-Mustervorlage gespeichert hatte.
1. Bei der Selektion mehrere Zellbereiche (2. und 3. Diagramm) kommt eine Fehlermeldung
2. Die Beschriftung der Datenpunkte funktioniert nicht richtig.
Mit einigen Klimmzügen im Makro hab ich es hinbekommen, dass das Diagramm erzeugt wird. Dabei wird das Diagramm auf Basis der ersten 2 Zeilen des Datenblocks erstelle und im Anschluß dann der selekterte Datenbereich zugewiesen.
Mit einer Erweiterung kann man alle Diagramme eines Datenblocks erzeugen, ohne jeweils die Zellen markieren zu müssen. Es muss dann nur die linke-obere Zelle des Datenbereichs vor dem Makrostart markiert werden.
Gruß
Franz
Sub TortenDiagramm_einfuegen()
Dim objChart As Chart
Dim objDataLabels As DataLabels
Dim rngData As Range
Dim dblTop As Double, dblLeft As Double
'Bei mehreren markierten Bereichen den Bereich für die Daten des Diagramms in _
einer Varialen neu zusammensetzen
If Selection.Areas.Count > 1 Then
Set rngData = Application.Union(Selection.Areas(1), Selection.Areas(2))
'die ersten Beiden Datenbereich für Diagramm-Erstellung markieren
rngData.Areas(1).Resize(2, rngData.Areas(1).Columns.Count).Select
Else
Set rngData = Selection
End If
'Top und Left-Position vorgeben
dblTop = rngData.Areas(1).Range("A1").Top
dblLeft = rngData.Areas(1).Range("A1").Offset(0, 5).Left
'Chartobject erstellen
ActiveSheet.ChartObjects.Add Top:=dblTop, Left:=dblLeft, _
Width:=153.54, Height:=130.67
Set objChart = ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count).Chart
With objChart
'Vorlage zuweisen
.ApplyChartTemplate ( _
"C:\Users\Admin\AppData\Roaming\Microsoft\Templates\Charts\KPI_TORMAX.crtx")
'Daten zuweisen
.SetSourceData Source:=rngData
'Beschriftung neu setzen
.ApplyDataLabels
Set objDataLabels = .SeriesCollection(1).DataLabels
With objDataLabels
.AutoText = True
.ShowCategoryName = False
.ShowLegendKey = False
.ShowSeriesName = False
.ShowValue = False
.ShowPercentage = True
End With
End With
rngData.Select
End Sub
Sub TortenDiagramm_Alle_einfuegen()
' Vor dem Start des Makros muss die linke ober Zelle des Datenbereichs der _
Diagramme selektiert werden
Dim objChart As Chart, objChartObject As ChartObject
Dim objDataLabels As DataLabels
Dim rngData As Range
Dim dblTop As Double, dblLeft As Double
Dim wks As Worksheet, Zeile As Long, Zeile1 As Long, Spalte1 As Long, Spalte2 As Long
Dim intDiagramm As Integer
If MsgBox("Ist die linke obere Zelle der Diagramm-Daten die aktive Zelle?", _
vbQuestion + vbOKCancel, "Diagramme erstellen") = vbCancel Then Exit Sub
Set wks = ActiveSheet
Zeile1 = ActiveCell.Row 'Zeile mit den Kategorien
Spalte1 = ActiveCell.Column 'Spalte mit den Reihennamen
Spalte2 = ActiveCell.End(xlToRight).Column 'letzte Spalte mit Diagrammdaten
intDiagramm = 0
For Zeile = Zeile1 + 1 To ActiveCell.End(xlDown).Row
With wks
'Bereich mit den Daten des Diagramms in einer Varialen zusammensetzen
Set rngData = Application.Union( _
.Range(.Cells(Zeile1, Spalte1), .Cells(Zeile1, Spalte2)), _
.Range(.Cells(Zeile, Spalte1), .Cells(Zeile, Spalte2)))
'Kategorien plus 1. Datenbereich selektieren (nur so fnktioniert Diagrammerstellung) _
.Range(.Cells(Zeile1, Spalte1), .Cells(Zeile1 + 1, Spalte2)).Select
'Top und Left-Position vorgeben
dblTop = .Cells(Zeile1, Spalte1).Top
dblLeft = .Cells(Zeile1, Spalte2 + 2 + intDiagramm * 3).Left - 20
intDiagramm = intDiagramm + 1
End With
'Chartobject erstellen
wks.ChartObjects.Add Top:=dblTop, Left:=dblLeft, _
Width:=153.54, Height:=130.67
Set objChart = wks.ChartObjects(wks.ChartObjects.Count).Chart
With objChart
'Vorlage zuweisen
.ApplyChartTemplate ( _
"C:\Users\Admin\AppData\Roaming\Microsoft\Templates\Charts\KPI_TORMAX.crtx")
'Daten zuweisen
.SetSourceData Source:=rngData
'Beschriftung neu setzen
.ApplyDataLabels
Set objDataLabels = .SeriesCollection(1).DataLabels
With objDataLabels
.AutoText = True
.ShowCategoryName = False
.ShowLegendKey = False
.ShowSeriesName = False
.ShowValue = False
.ShowPercentage = True
End With
End With
Next
End Sub