Balkenfarbe-Script vereinfachen

Hallo,
ich habe mit eure Hilfe folgendes, funktionierendes Script. Je nach "Wert" wird der dazugehörige Balken blau oder rot. Jetzt sind die vielen ElseIf-Befehle sehr unschön. Ich würde gern die Zuordnung "WertXY" zu rot oder blau nicht im Script direkt sondern in einem extra Tabellenblatt pflegen (s. Screenshot). Insbesondere da es sich um insgesamt ca.50 Werte handelt und auch manchmal welche ergänzt werden. Vielen Dank für eure Hilfe!

Sub Diagramm_formatieren()
Dim rng As Range
Dim i As Long
Dim a As Long
Dim l As Long
Dim e As Long
a = 0
For l = 1 To Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points.Count
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(l).Interior.ColorIndex = 1
Next l
For i = 1 To Worksheets(1).Range("H2").End(xlDown).Row
Set rng = Worksheets(1).Range("H2").Offset(i - 1, 0)
If rng.EntireRow.Hidden = False Then
If rng.Value = "Wert1" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 3
ElseIf rng.Value = "Wert2" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 3
ElseIf rng.Value = "Wert3" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 5
ElseIf rng.Value = "Wert4" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 5
ElseIf rng.Value = "Wert5" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 5
ElseIf rng.Value = "Wert6" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 3
ElseIf rng.Value = "Wert7" Then
Worksheets(1).ChartObjects("Diagramm 1").Chart.
SeriesCollection(1).Points(i - a).Interior.ColorIndex = 3
End If
Else
a = a + 1
End If
Next i
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Diagramm_formatieren() Dim rng As Range Dim i As Long Dim a As Long Dim l As Long Dim e As Long Dim WS As Worksheet Set WS = Worksheets("Hilfstabelle") ' Tabellennamen anpassen a = 0 For l = 1 To Worksheets(1).ChartObjects("Diagramm 1").Chart.SeriesCollection(1).Points. _ Count Worksheets(1).ChartObjects("Diagramm 1").Chart.SeriesCollection(1).Points(l).Interior. _ ColorIndex = 1 Next l For i = 1 To Worksheets(1).Range("H2").End(xlDown).Row Set rng = Worksheets(1).Range("H2").Offset(i - 1, 0) If rng.EntireRow.Hidden = False Then If WorksheetFunction.CountIf(WS.Columns(1), rng) > 0 Then _ Worksheets(1).ChartObjects("Diagramm 1").Chart.SeriesCollection(1).Points(i - a) _ .Interior.ColorIndex = 3 If WorksheetFunction.CountIf(WS.Columns(2), rng) > 0 Then _ Worksheets(1).ChartObjects("Diagramm 1").Chart.SeriesCollection(1).Points(i - a) _ .Interior.ColorIndex = 5 Else a = a + 1 End If Next i End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread