Diagramme erstellen und Wertebereiche zueisen
20.08.2023 16:14:10
Beverly
Das geht bei "richtigen" Diagrammen nur, indem man in der Zeichenfläche per VBA Shapes erstellt, welche die Flächen zwischen Horizontalachse und Datenreihe ausfüllen und entsprechend unterhalb der Horizonzalachse rot und oberhalb der Horizontalachse grün gefärbt werden. Das macht aus meiner Sicht jedoch keinen Sinn, weil das bei 50 Diagrammen 1. sehr lange dauert und 2. die Performance der Arbeitsmappe ungemein eingeschränken würde.
Hier ein Code, den du mal testen kannst (ausführen wenn "AAA" aktives Blatt ist):
' Start-Makro
Sub DiasErstellen()
Dim lngLetzte As Long
Dim intSpalte As Integer
Dim lngZeile As Long
Dim lngZiel As Long
Dim lngZaehler As Long
Dim chrDia As ChartObject
' mehr Diagramme als nur das "Vorlagen"-Diagramm sind vorhanden dann Makro
' zum Löschen der Diagramme aufrufen
If ActiveSheet.ChartObjects.Count > 1 Then DiasLoeschen
' Spalten B:P leeren
Columns("B:P").ClearContents
lngZiel = 2
lngZaehler = 2
lngLetzte = Worksheets("ROH1").Cells(Rows.Count, 1).End(xlUp).Row
' Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
' "Vorlagen"-Diagramm kopieren
ActiveSheet.ChartObjects(1).Copy
For lngZeile = 2 To lngLetzte
For intSpalte = 2 To 16 Step 2
' jeweils die Regal_Nr. eintragen
Cells(lngZiel, intSpalte) = Worksheets("ROH1").Cells(lngZaehler, 10)
' Kopierts Diagramm einfügen
ActiveSheet.Paste
' Positionen Oben und Links anpassen
With ActiveSheet.ChartObjects(ActiveSheet.ChartObjects.Count)
.Top = Cells(lngZiel, intSpalte).Top
.Left = Cells(lngZiel, intSpalte).Left
End With
lngZaehler = lngZaehler + 1
If lngZaehler > lngLetzte Then Exit For
Next intSpalte
If lngZaehler > lngLetzte Then Exit For
lngZiel = lngZiel + 3
Next lngZeile
ActiveSheet.ChartObjects(2).Delete
' Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = True
' Makro zum Zuweisen der Wertebereiche aufrufen
DiasWerteZuweisen
Range("A1").Select
End Sub
' Makro zum Zuweisen der betreffenden Wertebereiche
Sub DiasWerteZuweisen()
Dim chrDia As ChartObject
Dim serReihe As Series
Dim lngLetzte As Long
Dim lngZeile As Long
Dim intSpalte As Integer
Dim wks As Worksheet
Dim rngRegal As Range ' Variable für Regal-Nr in "ROHES", Suche in Zeile 1
Dim rngRegal2 As Range ' Variable für Regal-Nr in "ROH1", Suche in Spalte J
Dim dblMin As Double ' Minimum aus Spalte T
Dim dblMax As Double ' Maximum aus Spalte U
Dim dblInt As Double ' Intervall aus Spalte V
Dim dblCross As Double ' Schnittpunkt aus Spalte X
Set wks = Worksheets("ROHES")
lngLetzte = wks.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
' Schleife über alle Diagramme
For Each chrDia In ActiveSheet.ChartObjects
' Suche der Regal_Nr in Zeile 1 in ROHES
Set rngRegal = wks.Rows(1).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole)
' Suche der Regal_Nr in Spalte J in ROH1
Set rngRegal2 = Worksheets("ROH1").Columns(10).Find(chrDia.TopLeftCell.Value, lookat:=xlWhole, LookIn:=xlValues)
chrDia.Select
intSpalte = rngRegal.Column
' Achsenwerte
dblMin = Worksheets("ROH1").Cells(rngRegal2.Row, "T")
dblMax = Worksheets("ROH1").Cells(rngRegal2.Row, "U")
dblInt = Worksheets("ROH1").Cells(rngRegal2.Row, "V")
dblCross = Worksheets("ROH1").Cells(rngRegal2.Row, "X")
' Hauptintervall muss > 0 sein sonst Laufzeitfehler
If dblInt > 0 Then
With chrDia.Chart
' Schleife über alle Datenreihen und Zuweisung der Zellen/Zellbereiche in Abhängigkeit vom Namen
For Each serReihe In .SeriesCollection
Select Case serReihe.Name
Case "Datenreihen1", "FLÄCHE"
serReihe.Values = "=ROHES!" & Range(Cells(30, intSpalte), Cells(lngLetzte, intSpalte)).Address
Case "Beschriftung_min"
serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "P").Address
serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "Q").Address
Case "Beschriftung_max"
serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "R").Address
serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "S").Address
Case "Start"
serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "W").Address
serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "X").Address
Case "Ende"
serReihe.XValues = "=ROH1!" & Cells(rngRegal2.Row, "Y").Address
serReihe.Values = "=ROH1!" & Cells(rngRegal2.Row, "Z").Address
End Select
Next serReihe
' Achsenwerte einstellen
.Axes(xlValue).MinimumScale = dblMin
.Axes(xlValue).MaximumScale = dblMax
.Axes(xlValue).CrossesAt = dblCross
' Diagramm aktualisieren
.Refresh
End With
Else
' Diagramm löschen wenn Hauptintervall = 0 da keine Daten vorhanden
chrDia.Delete
End If
Next chrDia
Application.ScreenUpdating = True
End Sub
' Makro zum Löschen vorhandener Diagramme außer dem "Vorlagen"-Diagramm
Sub DiasLoeschen()
Dim chrDia As ChartObject
Dim intDia As Integer
With Worksheets("AAA")
' mehr als 1 Diagramm sind vorhanden
If .ChartObjects.Count > 1 Then
' alle Diagramme löschen vom zuletzt erstellten bis einschließlich zweitem Diagramm
' sodass das 1. Diagramm immer erhalten bleibt
For intDia = .ChartObjects.Count To 2 Step -1
.ChartObjects(intDia).Delete
Next intDia
End If
End With
End Sub
Bis später
Karin
https://excel-inn.de/