Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1692to1696
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bedingte Formatierung für Diagramme

Bedingte Formatierung für Diagramme
26.05.2019 16:43:52
Rainer
Hallo Excel-Freunde,
Fortsetzung von hier:
https://www.herber.de/cgi-bin/callthread.pl?index=1560622
und motiviert durch hier:
https://www.herber.de/forum/archiv/1692to1696/t1694469.htm#1694469
Habe ich das Makro noch weiter verbessert und teile es mit euch:
Sub Conditional_Format_for_Graphs_V2()
'Select a Series from a Chart, the Points will be coloured according to the Background Colour
'Also works with Conditional Formating of the Cells
'Tested for Column Chart, Line chart with Markers, Pie and doughnut charts, Doughnut Charts,  _
Bar Chart
'XY (scatter) and bubble chart, Bubble Chart
'Treemap chart (Office 2016 and newer versions only)
'Sunburst chart (Office 2016 and newer versions only)
'Waterfall charts (Office 2016 and newer versions only)
'Map chart (Excel only)
'Not working with: Area Chart, Stock Chart, Surface Chart, Radar Charts
'Histogram charts (Office 2016 and newer versions only)
'Box and Whisker charts (Office 2016 and newer versions only)
'Funnel charts (Office 2016 and newer versions only)
'Combo charts (Office 2013 and newer versions only)
Dim RaZelle As Range
On Error Resume Next
test = ActiveChart.Name
If IsEmpty(ActiveChart.Name) Then
MsgBox "Select Graph first", vbCritical
Exit Sub
End If
If TypeName(Selection) = "Series" Then
Set ch = ActiveChart.SeriesCollection
For SeriesI = 1 To ch.Count
If ch(SeriesI).Name = Selection.Name Then I = SeriesI
Next SeriesI
Else
If MsgBox("No Series selected, continue with Series 1?", vbYesNo, "Warning") = vbYes Then
I = 1
Else
Exit Sub
End If
End If
SeriesI = I
SeriesFormula = ActiveChart.SeriesCollection(SeriesI).Formula
X1 = InStr(SeriesFormula, ",")             'Ende Name
X1 = InStr(X1 + 1, SeriesFormula, ",")      'Ende X-Achse
X2 = InStr(X1 + 1, SeriesFormula, "!")      'Ende Blattname
X1 = InStr(X1 + 1, SeriesFormula, ",")
ValueRange = Mid(SeriesFormula, X2 + 1, X1 - X2 - 1)
If ValueRange = "" Then                 'Treemap
Dim chtObj1 As ChartObject
Dim chtObj2 As ChartObject
Set chtObj1 = ActiveChart.Parent
Set chtObj2 = chtObj1.Duplicate.Chart.Parent
chtObj2.Activate
ActiveChart.ChartType = xlLine
SeriesFormula = ActiveChart.SeriesCollection(1).Formula
X1 = InStr(SeriesFormula, ",")             'Ende Name
X1 = InStr(X1 + 1, SeriesFormula, ",")      'Ende X-Achse
X2 = InStr(X1 + 1, SeriesFormula, "!")      'Ende Blattname
X1 = InStr(X1 + 1, SeriesFormula, ",")
ValueRange = Mid(SeriesFormula, X2 + 1, X1 - X2 - 1)
ActiveChart.Parent.Delete
chtObj1.Activate
ActiveChart.FullSeriesCollection(1).Select
End If
I = 1
For Each RaZelle In ActiveSheet.Range(ValueRange)
If RaZelle.DisplayFormat.Interior.Color  16777215 Then
ActiveChart.SeriesCollection(SeriesI).Points(I).Format.Fill.ForeColor.RGB = _
RaZelle.DisplayFormat.Interior.Color
End If
I = I + 1
Next RaZelle
End Sub
Gruß,
Rainer

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
  • 26.05.2019 17:40:35
    Hajo_Zi
Anzeige
gelöst
26.05.2019 17:40:35
Hajo_Zi
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige