AW: Bedingte Formatierung Diagramm-VBA
11.12.2016 12:25:29
fcs
Hallo Monika,
die Programmierung von Diagrammen unter VBA ist wegen der Vielzahl an Optionen etwas aufwendig.
Ich hab deinen Wunsch fast umsetzen können, es aber nicht geschafft die Farbe der Schraffur in die Farbe der Linien umzuwandeln.
Zur einfacheren Programmierung hab ich dein Makro auch etwas umgestellt.
LG
Franz
Sub TEST()
Dim wbName2 As String
Dim objChart As Chart, objReihe As Series, objPoint As Point
Dim lngColor As Long, lngWhite As Long, lngBlack As Long, Zeile As Long
Dim Zahl As Integer
wbName2 = "b = f(u)"
If SheetExists(wbName2) Then
Else
Charts.Add
ActiveSheet.Name = wbName2
End If
Set objChart = Sheets(wbName2)
'im Diagramm-Blatt ggf. alle Datenreihen löschen
With objChart
For Zahl = .SeriesCollection.Count To 1 Step -1
.SeriesCollection(Zahl).Delete
Next
End With
'Zahl = ActiveChart.SeriesCollection.Count
'MsgBox Zahl
With objChart
.ChartType = xlXYScatterLines
lngWhite = RGB(Red:=255, green:=255, blue:=255)
lngBlack = RGB(Red:=0, green:=0, blue:=0)
For Zahl = 1 To 2
'neue Datenreihe anlegen
.SeriesCollection.NewSeries
Set objReihe = .SeriesCollection(Zahl)
With objReihe
Select Case Zahl
Case 1 'ImageJ
.Name = "ImageJ"
.XValues = Range("Tabelle1[Geschwindigkeit" & Chr(10) & "'[m/min']]")
.Values = Range("Tabelle1[Strichtbreite" & Chr(10) & "ImageJ '[mm']]")
lngColor = RGB(Red:=255, green:=0, blue:=0) 'rot
Case 2 'Laser
.Name = "Laser"
.XValues = Range("Tabelle1[Geschwindigkeit" & Chr(10) & "'[m/min']]")
.Values = Range("Tabelle1[Strichtbreite" & Chr(10) & "Laser '[mm']]")
lngColor = RGB(Red:=0, green:=0, blue:=255) 'blau
End Select
'allgemeine Formatierung der Diagrammreihe
With .Format.Line
.Visible = msoTrue
.DashStyle = msoLineSolid
.Weight = 2
.ForeColor.RGB = lngColor
End With
'Basisformatierung der Datenpunkte
.MarkerForegroundColor = lngBlack 'Farbe Symbol
.MarkerBackgroundColor = lngColor
.MarkerSize = 12
End With
'spezielle Formatierung der Datenpunkte
With Range("Tabelle1[Geschwindigkeit" & Chr(10) & "'[m/min']]")
For Zeile = 1 To .Rows.Count
Set objPoint = objReihe.Points(Zeile)
With .Cells(Zeile, 1)
If .Offset(0, 2) = "a" Then 'Stabil
'Basisformatierung nicht ändern
ElseIf .Offset(0, 5) = "a" Then 'Instabil
objPoint.MarkerBackgroundColor = lngWhite
Else 'Übergang / wandernder Miniskus
With objPoint.Format.Fill
.Visible = msoTrue
.Patterned (16) ' msoPatternDarkUpwardDiagonal
End With
End If
End With
Next Zeile
End With
Next Zahl
End With
End Sub