Gestapeltes Diagramm mit Zellfarbe färbe

Hallo zusammen,
ich habe ein Problem, ein gestapeltes Säulendiagramm mit der Zellfarbe (bedingte Formatierung) einzufärben.
Es sollen insgesamt vier Säulendiragramme (bestendend aus den 4 vertikalen werten, aus den Spalten B :E) entstehen.
Anbei ein Bild:
Userbild

ich habe zwei Ansätze gefahren, jedoch färben sich die "Säulenblöcke" nicht wie gewünscht.


ActiveChart.ChartArea.Select
Application.ScreenUpdating = False
ActiveChart.ChartType = xlColumnStacked 'gestapeltes Säulendiagramm
ActiveChart.SetSourceData Source:=Range(Sheets("Analyse-Tool").Cells(9, 2), Sheets("Analyse-Tool").Cells(6, 2))
ActiveChart.PlotBy = xlRows
With ActiveChart
.HasTitle = True
.HasLegend = False
.HasDataTable = False
.AutoScaling = True
.ChartTitle.Text = "....."
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory).AxisTitle.Text = "...."
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue).AxisTitle.Text = "Status"
.Axes(xlValue, xlPrimary).MaximumScale = 25
.Axes(xlValue, xlPrimary).MinimumScale = 0
End With
'%%%%%%%%%%%%%%% Versuch 1 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'Loop through all charts in the active sheet
For Each oChart In ActiveSheet.ChartObjects
'Loop through all series in the target chart
For Each MySeries In oChart.Chart.SeriesCollection
'Get Source Data Range for the target series
FormulaSplit = Split(MySeries.Formula, ",")
'Capture the first cell in the source range then trap the color
'  Set SourceRange = Range(FormulaSplit(2)).Item(1)
Set SourceRange = Range("B6:B9").Item(1)
SourceRangeColor = SourceRange.Interior.Color
'Coloring for Excel 2007 and 2010
' MySeries.MarkerBackgroundColor = SourceRangeColor
' MySeries.MarkerForegroundColor = SourceRangeColor
MySeries.Format.Line.ForeColor.RGB = SourceRangeColor
MySeries.Format.Line.BackColor.RGB = SourceRangeColor
MySeries.Format.Fill.ForeColor.RGB = SourceRangeColor
Next MySeries
Next oChart
'%%%%%%%%%%%%%%% Versuch 2 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
With ActiveSheet.ChartObjects(1).Chart
Set Rng = ActiveSheet.Range("B6:B9")
j = 6
Set iColor = Range("B6:B9")
For i = 1 To 4
ActiveChart.SeriesCollection(i).Format.Fill.ForeColor.RGB = iColor(i).Interior.Color
ActiveChart.SeriesCollection(i).Format.Line.ForeColor.RGB = iColor(i).Interior.Color
ActiveChart.SeriesCollection(i).Format.Line.BackColor.RGB = iColor(i).Interior.Color
j = j + 1
Next i
End With
Beste Grüße und vielen Lieben Dank im Voraus
Lionel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub tt() Dim intZeile As Integer, intSpalte As Integer Dim rngBereich As Range: Set rngBereich = Worksheets("Tabelle1").Range("B6:E9") Application.ScreenUpdating = False With rngBereich For intZeile = .Row To .Row + .Rows.Count - 1 For intSpalte = .Column To .Column + .Columns.Count - 1 ActiveSheet.ChartObjects("Diagramm " & intSpalte - .Column + 1).Activate ActiveChart.FullSeriesCollection(intZeile - .Row + 1).Format.Fill.ForeColor.RGB = _ Worksheets("Tabelle1").Cells(intZeile, intSpalte).DisplayFormat.Interior.Color Next intSpalte Next intZeile End With End Sub

Sub DiaFaerben() Dim chrDia As ChartObject Dim rngBereich As Range Dim strZelle As String Dim serReihe As Series For Each chrDia In Worksheets("Tabelle2").ChartObjects For Each serReihe In chrDia.Chart.SeriesCollection strZelle = Split(serReihe.Formula, ",")(2) serReihe.Interior.Color = Range(strZelle).DisplayFormat.Interior.Color Next serReihe Next chrDia End Sub

Beliebteste Forumthreads (12 Monate)

Gestapeltes Diagramm mit Zellfarbe färbe

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread