AW: Farben Blasen-Diagramm
07.07.2015 16:56:29
Beverly
Hi Marc,
ich war von einer falschen Voraussetzung bei der Berechnung deiner Top-Werte ausgegangen - so sollte der Code für beide Varianten funktionieren:
Sub Top_3()
Dim lngPunkt As Long
Dim serReihe As Series
Dim strFormel As String
With ActiveSheet.ChartObjects(1).Chart
Set serReihe = .SeriesCollection(1)
With serReihe
If .HasDataLabels = True Then .DataLabels.Delete
.ApplyDataLabels
' Schrift - Werte entsprechend anpassen
With serReihe.DataLabels.Font
.Name = "Arial"
.Size = 10
.Color = 255
End With
strFormel = Application.Substitute(Split(.Formula, ",")(4), ")", "")
For lngPunkt = 1 To .Points.Count
.Points(lngPunkt).DataLabel.Text = Range(strFormel).Cells(lngPunkt).Offset(0, - _
9).Value
.Points(lngPunkt).Format.Line.Visible = msoFalse
If Range(strFormel).Cells(lngPunkt).Offset(0, -9) "" Then
With .Points(lngPunkt).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1.5
.Transparency = 0
End With
End If
Next lngPunkt
End With
Set serReihe = Nothing
End With
End Sub
Sub Prozent80()
Dim lngPunkt As Long
Dim serReihe As Series
Dim strFormel As String
With ActiveSheet.ChartObjects(1).Chart
Set serReihe = .SeriesCollection(1)
With serReihe
If .HasDataLabels = True Then .DataLabels.Delete
.ApplyDataLabels
' Schrift - Werte entsprechend anpassen
With serReihe.DataLabels.Font
.Name = "Arial"
.Size = 10
.Color = 255
End With
strFormel = Application.Substitute(Split(.Formula, ",")(4), ")", "")
For lngPunkt = 1 To .Points.Count
.Points(lngPunkt).DataLabel.Text = Range(strFormel).Cells(lngPunkt).Offset(0, - _
8).Value
.Points(lngPunkt).Format.Line.Visible = msoFalse
If Range(strFormel).Cells(lngPunkt).Offset(0, -10)
Der Code stellt aus der Datenreihenformel den Zellbereich fest, in dem die Blasengrößen stehen (Spalte L). Davon ausgehend vergleicht er in der Schleife, ob in der Spalte C (bei Top 3) in der laufenden Zeile ein Wert steht, bzw. (bei 80%) der Wert in Spalte B kleiner-gleich dem Wert in D1 ist (so wie deine Formel in Spalte D). Auf dieser Basis wird dann entschieden, ob der Rahmen gesetzt wird oder nicht.
Bezüglich der Färbung nach Marken:
Sub MarkeFaerben()
Dim arrFarben()
Dim strFarbe As String
Dim bytFarbe As Byte
Dim lngPunkt As Long
Dim serReihe As Series
Dim strFormel As String
Dim pktPunkt As Point
arrFarben = Array(Array("Adidas", "Puma", "Nike"), Array(255, 15773696, 5296274))
With ActiveSheet.ChartObjects(1).Chart
Set serReihe = .SeriesCollection(1)
With serReihe
strFormel = Application.Substitute(Split(.Formula, ",")(4), ")", "")
For lngPunkt = 1 To .Points.Count
If Range(strFormel).Cells(lngPunkt) "" Then
strFarbe = Range(strFormel).Cells(lngPunkt).Offset(0, -4).Value
bytFarbe = Application.Match(strFarbe, arrFarben(0), 0)
Set pktPunkt = .Points(lngPunkt)
pktPunkt.Interior.Color = arrFarben(1)(bytFarbe - 1)
End If
Next lngPunkt
End With
Set serReihe = Nothing
Set pktPunkt = Nothing
End With
End Sub
Es muss allerdings garantiert sein, dass alle Marken, die in Spalte H aufgeführt sind und die dazügehörigen Farben im Array enthalten sind. Das Array lässt sich selbstverständlich entsprechend erweitern.
Alles komplett wieder zurücksetzen kannst du dann mit diesem Makro:
Sub AllesZurueck()
Dim lngPunkt As Long
Dim serReihe As Series
With ActiveSheet.ChartObjects(1).Chart
Set serReihe = .SeriesCollection(1)
With serReihe
If .HasDataLabels = True Then .DataLabels.Delete
For lngPunkt = 1 To .Points.Count
.Points(lngPunkt).Format.Line.Visible = msoFalse
With .Points(lngPunkt).Format.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
End With
Next lngPunkt
End With
Set serReihe = Nothing
End With
End Sub
https://www.herber.de/bbs/user/98682.xlsm