AW: Punkte im Punktdiagramm einfärben (abhängig von We
25.02.2015 16:14:58
We
Hallo Leonhard,
ein paar Sachen sind grundsätzlicher Natur, wenn man Datenpunkte individuell formatieren will. Die hab ich aus meinem Fundus ausgegraben.
Die Werte/Farbprüfungen sind dann speziell zugeschnitten.
Nachfolgend das Makro angepasst auf deine gewünschten Bereiche für die KBPS-Werte und Farben.
Gruß
Franz
Sub FormatPoints()
Dim wksData As Worksheet, Zeile As Long
Dim dblMin As Double, dblMax As Double
Dim objChart As Chart, objPoint As Point
Dim lngFarbe(1 To 5) As Long, intFarbe As Integer
Dim dblWert(1 To 5) As Double
Set wksData = Worksheets("Datensatz")
Set objChart = Worksheets("Grafik").ChartObjects(1).Chart
With wksData
'Min- und Max-Wert der Download KBPS ermitteln
With .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
dblMin = .Application.WorksheetFunction.Min(.Cells)
dblMax = .Application.WorksheetFunction.Max(.Cells)
End With
End With
'Farbwerte für die 5 Stufen - 1 = niedrige KBPS, 5 = hohe KBPS
dblWert(1) = 1000: lngFarbe(1) = RGB(Red:=102, Green:=255, Blue:=255) 'hellblau
dblWert(2) = 5000: lngFarbe(2) = RGB(Red:=0, Green:=255, Blue:=0) 'Green
dblWert(3) = 10000: lngFarbe(3) = RGB(Red:=255, Green:=255, Blue:=0) 'gelb
dblWert(4) = 20000: lngFarbe(4) = RGB(Red:=255, Green:=192, Blue:=0) 'Orange
dblWert(5) = 20000: lngFarbe(5) = RGB(Red:=255, Green:=0, Blue:=0) 'rot
Zeile = 1 'Zeile mit den Spaltentiteln in der Tabele mit den Quelldaten des Diagramms
For Each objPoint In objChart.SeriesCollection(1).Points
Zeile = Zeile + 1
If IsEmpty(wksData.Cells(Zeile, 3)) Then Exit For
intFarbe = 0
Select Case wksData.Cells(Zeile, 3)
Case Is = dblWert(5)
intFarbe = 5
End Select
If intFarbe > 0 Then
With objPoint
.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
.MarkerBackgroundColor = lngFarbe(intFarbe)
End With
End If
Next
'Farblegende unter Diagramm eintragen in zeile 40 einfügen
With Worksheets("Grafik")
.Rows(40).Clear
For intFarbe = LBound(lngFarbe) To UBound(lngFarbe)
.Cells(40, (intFarbe - 1) * 2 + 1).Interior.Color = lngFarbe(intFarbe)
If intFarbe UBound(lngFarbe) Then
.Cells(40, (intFarbe - 1) * 2 + 1).Value = _
"'=" & Format(dblWert(intFarbe), "0")
End If
Next
.Cells(40, (UBound(lngFarbe)) * 2 + 1).Value = "KBPS"
End With
End Sub