per VBA erstellte Diagramme variieren in der Höhe
16.03.2025 09:34:35
AS
Ich sitze hier nun seit Stunden und verzweifle langsam..
Folgende Ausgangssituation: Ich möchte verschiedene Datenreihen (die regelmäßig erweitert werden), in verschiedenen Diagrammen darstellen. In Spalte B und C stehen die Messwerte (10 bzw. 12 etc.), in der Spalte G die unterschiedlichen Varianten (apfel, birne, ...), für die ich jeweils die passenden Werte zusammen darstellen möchte.
Beim Diagramm soll später also auf der vertikalen Achse der Wert aus Spalte B bzw. Spalte C stehen, die verschiedenen Varianten aus Spalte G geben vor, welche Werte aus Spalte B bzw. C genommen werden.
Die Werte, die auf der horizontalen Achse dargestellt werden, stehen in Spalte H (1, 2, 3).
Bei untenstehender Tabelle würde es also 2 Tabellen geben, bei denen auf der horizontalen Achse 1, 2 und 3 steht und jeweils der passende Wert links aus Spalte B aufgetragen wird und 2 Tabellen geben, bei denen auf der horizontalen Achse 1, 2 und 3 steht und jeweils der passende Wert links aus Spalte C aufgetragen wird.
In einem späteren Schritt wollte ich es dann noch so machen, dass immer nur die neuesten Daten im Diagramm angezeigt werden sollen (in Spalte J steht jeweils die Kalenderwoche). Soweit war ich aber noch nicht..
10 12 apfel 1 11
11 13 apfel 2 11
9 11 apfel 3 11
10 13 birne 1 11
8 14 birne 2 11
10 11 birne 3 11
8 12 apfel 1 12
9 13 apfel 2 12
11 11 apfel 3 12
13 13 birne 1 12
7 14 birne 2 12
12 11 birne 3 12
Dazu habe ich folgenden Code geschrieben:
Sub DiagrammeErstellen()
Dim ws As Worksheet
Dim lastRow As Long
Dim variante As String
Dim i As Long
Dim chartObj As ChartObject
Dim chartRange As Range
Dim chart As chart
Dim uniquevarianten As Collection
Dim cell As Range
Dim item As Variant
Dim startColumn As Long
Dim startRow As Long
Dim startRow2 As Long
Dim chartHeight As Long
Dim chartWidth As Long
Set ws = ThisWorkbook.ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
Set uniquevarianten = New Collection
On Error Resume Next
For i = 2 To lastRow
variante = ws.Cells(i, "G").Value
uniquevarianten.Add variante, CStr(variante)
Next i
On Error GoTo 0
startRow = 2
startRow2 = 20
startColumn = 12
chartHeight = ws.Cells(1, 1).Height * 5
chartWidth = ws.Cells(1, 1).Width * 5
For Each item In uniquevarianten
variante = item
ws.Rows(1).AutoFilter Field:=7, Criteria1:=variante
Set chartObj = ws.ChartObjects.Add(Left:=ws.Cells(startRow, startColumn).Left, Width:=chartWidth, Top:=ws.Cells(startRow, startColumn).Top, Height:=chartHeight)
Set chart = chartObj.chart
chart.SetSourceData Source:=ws.Range("B1:B" & lastRow).SpecialCells(xlCellTypeVisible)
chart.ChartType = xlLine
chart.HasTitle = True
chart.ChartTitle.Text = ActiveSheet.Name & " " & variante & " varianteB"
chart.Axes(xlCategory, xlPrimary).HasTitle = True
chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Punkt"
chart.Axes(xlValue, xlPrimary).HasTitle = True
chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "werte varianteB"
Set chartObj = ws.ChartObjects.Add(Left:=ws.Cells(startRow2, startColumn).Left, Width:=chartWidth, Top:=ws.Cells(startRow2, startColumn).Top, Height:=chartHeight)
Set chart = chartObj.chart
chart.SetSourceData Source:=ws.Range("C1:C" & lastRow).SpecialCells(xlCellTypeVisible)
chart.ChartType = xlLine
chart.HasTitle = True
chart.ChartTitle.Text = ActiveSheet.Name & " " & variante & " varianteC"
chart.Axes(xlCategory, xlPrimary).HasTitle = True
chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "Punkt"
chart.Axes(xlValue, xlPrimary).HasTitle = True
chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "werte varianteC"
ws.Rows(1).AutoFilter
startColumn = startColumn + 5
Next item
End Sub
Die Diagramme werden nicht zuverlässig erstellt und wenn sie erstellt werden, variiert die Höhe und auch der Startpunkt. Ich möchte allerdings zwei Reihen erhalten, die immer den gleichen Abstand zueinander haben, bei denen auch alle Diagramme immer gleich groß sind.
Über jede Anregung und Hilfe wäre ich sehr dankbar!
Viele Grüße
Alex
Anzeige