Supportnet / Forum / Tabellenkalkulation
Säulenfarbe = Zellenfarbe ???
Frage
Guten Morgen zusammen,
Gibt es eine Möglichkeit, die Farbe einer Säule abhängig von der Farbe der Zelle, auf die sich die Säule bezieht, zu verbinden?
Konkret
Wenn die Zelle blau ist, dann soll auch die Säule blau sein.
Wenn die Zelle rot ist, soll die Farbe der Säule sich zu rot verändern.
Ich denke dabei an eine bedingte Formatierung der Zelle, wo je nach Zahl der Hintergrund eine unterschiedliche Farbe annimmt. Dies soll sich dann auch in dem Diagramm wiederspiegeln.
Danke schonmal im voraus,
Tom
Antwort 1 von piano
Hallo
Hier ein Makro dazu als Muster:
Viel Spaß beim ausprobieren!
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
Hier ein Makro dazu als Muster:
Sub DiagrammFarben()
'
Dim Element As Object, Zeile1 As Integer, Spalte1 As Integer
Dim TabName As String, DiaName As String, TRange As String
Dim Zelle As Range
Dim FarbArray()
Dim i As Integer, i1 As Integer, fi As Integer
TabName = InputBox("Tabellenname der Source-Daten:", , "Vorschau")
DiaName = InputBox("Tabellenname des Diagramms:", , "Diagramm")
TRange = InputBox("Bereich der Sourcedaten (B13:E14):", , "B13:E14")
If TabName = "" Or DiaName = "" Or TRange = "" Then Exit Sub
'Farben auslesen
Worksheets(TabName).Activate
Range(TRange).Select
ReDim FarbArray(1 To Selection.Count)
fi = 0
For Each Zelle In Selection
fi = fi + 1
FarbArray(fi) = Zelle.Interior.ColorIndex
Next Zelle
'Farben zuweisen
On Error Resume Next
Worksheets(DiaName).Activate
Charts(DiaName).Activate ' wenn eigenes Chart
ActiveSheet.chartsobjects(1).Select
Application.ScreenUpdating = False
fi = 1
For i = 1 To ActiveChart.SeriesCollection.Count
For i1 = 1 To ActiveChart.SeriesCollection(i).Points.Count
ActiveChart.SeriesCollection(i).Points(i1).Select
Selection.InvertIfNegative = False
With Selection.Interior
.ColorIndex = FarbArray(fi)
.Pattern = xlSolid
End With
fi = fi + 1
Next i1
Next i
Application.ScreenUpdating = True
End Sub
Viel Spaß beim ausprobieren!
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
Antwort 2 von Karneval
Hallo, habe das gleiche Problem. Habe das Makro probiert, bekomme aber Laufzeitfehler 9, Index ausserhalb des gültigen Bereichs.
Der Bereich meiner Quelldaten ist A1:B83
Vielen Dank.
Der Bereich meiner Quelldaten ist A1:B83
Vielen Dank.
Antwort 3 von piano
Hallo
Hier ein leicht modifizierter Code für Diagramm in eigenem sheet.
Dad Diagramm muß natürlich bereits erstellt sein. Getestet mit normalem Säulendiagramm:
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
- probieren geht über studieren -
Hier ein leicht modifizierter Code für Diagramm in eigenem sheet.
Dad Diagramm muß natürlich bereits erstellt sein. Getestet mit normalem Säulendiagramm:
Sub DiagrammFarbenChart()
' Für Diagramm in eigenem Sheet !!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim Element As Object, Zeile1 As Integer, Spalte1 As Integer
Dim TabName As String, DiaName As String, TRange As String
Dim Zelle As Range
Dim FarbArray()
Dim i As Integer, i1 As Integer, fi As Integer
TabName = InputBox("Tabellenname der Source-Daten:", , "Tabelle1")
DiaName = InputBox("Tabellenname des Diagramms:", , "Tabelle1")
TRange = InputBox("Bereich der Sourcedaten (B13:E14):", , "A1:B28")
If TabName = "" Or DiaName = "" Or TRange = "" Then Exit Sub
'Farben auslesen
Worksheets(TabName).Activate
Range(TRange).Select
ReDim FarbArray(1 To Selection.Count)
fi = 0
For Each Zelle In Selection
fi = fi + 1
FarbArray(fi) = Zelle.Interior.ColorIndex
Next Zelle
'Farben zuweisen
On Error Resume Next
Charts(DiaName).Activate
ActiveChart.Select
Application.ScreenUpdating = False
fi = 1
For i = 1 To ActiveChart.SeriesCollection.Count
For i1 = 1 To ActiveChart.SeriesCollection(i).Points.Count
ActiveChart.SeriesCollection(i).Points(i1).Select
Selection.InvertIfNegative = False
With Selection.Interior
.ColorIndex = FarbArray(fi)
.Pattern = xlSolid
End With
fi = fi + 1
Next i1
Next i
ActiveChart.ChartArea.Select
Application.ScreenUpdating = True
End Sub
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
- probieren geht über studieren -
Antwort 4 von Karneval
@piano Danke für die Mühe.
Es funktioniert aber nicht bei mir. Es macht mir alle Felder der Quelldatei (auf die sich das Diagramm beruft) farbig. Vielleicht mache ich ja auch was falsch! Ich erstelle eine einfache Datei, 2 Spalten mit Werten. Die 2. Spalte wird farbig unterschiedlich, nach den WQerten hinterlegt. das Makro habe ich vorher erstellt. jetzt erstelle ich das Diagramm und anschliessend auf das entsprechende Makro Ausführen.
Gruß Karneval
Es funktioniert aber nicht bei mir. Es macht mir alle Felder der Quelldatei (auf die sich das Diagramm beruft) farbig. Vielleicht mache ich ja auch was falsch! Ich erstelle eine einfache Datei, 2 Spalten mit Werten. Die 2. Spalte wird farbig unterschiedlich, nach den WQerten hinterlegt. das Makro habe ich vorher erstellt. jetzt erstelle ich das Diagramm und anschliessend auf das entsprechende Makro Ausführen.
Gruß Karneval
Antwort 5 von piano
Hallo
Nachtrag:
TRange = InputBox("Bereich der Sourcedaten (A1:B28):", , "B2:B28")
Hier nur den reinen Datenbereich anführen (ohne Spalten- und Zeilenüberschriften!
Nachtrag:
TRange = InputBox("Bereich der Sourcedaten (A1:B28):", , "B2:B28")
Hier nur den reinen Datenbereich anführen (ohne Spalten- und Zeilenüberschriften!
Antwort 6 von piano
????? funktioniert es schon ???????
Bei mir unter Office XP getestet!
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
- probieren geht über studieren -
Bei mir unter Office XP getestet!
Gruß piano
Es wäre nett, wenn Du ein Feedback abgeben könntest,
ob der Lösungsvorschlag Dein Problem gelöst hat.
- probieren geht über studieren -