AW: Diagramm färben
25.02.2016 15:08:27
Steve
Hallo Stef,
da hast du dir aber was interessantes ausgesucht, zumindest für jemanden mit Basiskenntnissen ist das sicher eine Nummer zu groß.
Das erste was du tun musst ist aus den Diagrammen die Werte ermitteln. Dies bedarf schon etwas Aufwand, denn in deinem Balkendiagramm ist jeder Wert eine eigene SeriesCollection. Wo wir einmal dabei sind, unter Office 2010 heist der Befehl nur 'SeriesCollectionn' und nicht 'FullSeriesCollection', das solltest für dich noch anpassen da ich es mit O.2013 getestet habe.
Das Problem mit diesen Serien ist jedoch, dass die Werte nicht direkt gespeichert sind, sondern nur eine Formel wo die Zelle bezeichnet ist. Bsp.:
"=SERIES(Tabelle1!$B$3,,Tabelle1!$C$3,1)"
In dem Fall brauche ich die erste Adresse "$B$3" und muss das aus der Formel mittels der Funktion 'Teil' (=MID) erst dort rausholen. Dies muss ich für jede Serie tun und in einem Datenfeld (Array) speichern. Dann kann ich die Werte der Zellen deren Adressen ich nun habe miteinander vergleichen. Kam der Wert bereits vor, so bekommt er die Farbe des Vergleichswertes, wenn nicht bekommt er eine neue Farbe.
Diese habe ich wie schön zu sehen in einem SelectCase-Befehl angeordnet, sodass du dir mit dem Makrorecorder die Farben selber zurechtfummeln kannst. Eventuell musst du noch ein paar mehr Farben hinzufügen, das hängt von deinen Diagrammen ab. Für dein erstes Beispieldiagramm haben halt sechs Stück ausgereicht.
Sub Test()
Dim oShape As Shape, oCol
Dim dAddress()
Dim i As Long, j As Long, x As Long, y As Long, z As Long
For Each oShape In Tabelle1.Shapes
If oShape.Name Like "Diagramm*" Or oShape.Name Like "Chart*" Then
For Each oCol In oShape.Chart.FullSeriesCollection
ReDim Preserve dAddress(4, i)
dAddress(0, i) = fAddress(oCol.Formula)
i = i + 1
Next oCol
For x = 0 To i - 1
If j = 0 Then GoTo NewColor
For y = 0 To j
If Tabelle1.Range(dAddress(0, x)) = Tabelle1.Range(dAddress(0, y)) And x y _
Then GoTo NoNewColor
Next y
NewColor:
Select Case z
' ThemeColor / TintAndShade / Brightness / Transparency
Case 0: dAddress(1, x) = msoThemeColorAccent6
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
Case 1: dAddress(1, x) = msoThemeColorAccent5
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
Case 2: dAddress(1, x) = msoThemeColorAccent4
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
Case 3: dAddress(1, x) = msoThemeColorAccent3
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
Case 4: dAddress(1, x) = msoThemeColorAccent2
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
Case 5: dAddress(1, x) = msoThemeColorAccent1
dAddress(2, x) = 0
dAddress(3, x) = -0.25
dAddress(4, x) = 0
End Select
z = z + 1
GoTo Coloring
NoNewColor:
dAddress(1, x) = dAddress(1, y)
dAddress(2, x) = dAddress(2, y)
dAddress(3, x) = dAddress(3, y)
dAddress(4, x) = dAddress(4, y)
Coloring:
With oShape.Chart.FullSeriesCollection(x + 1).Format.Fill
.ForeColor.ObjectThemeColor = dAddress(1, x)
.ForeColor.TintAndShade = dAddress(2, x)
.ForeColor.Brightness = dAddress(3, x)
.Transparency = dAddress(4, x)
End With
j = j + 1
Next x
End If
Next oShape
End Sub
Private Function fAddress(sFormula As String)
fAddress = Mid(sFormula, InStr(sFormula, "!") + 1, InStr(sFormula, ",") - InStr(sFormula, "! _
") - 1)
End Function
lg Steve