AW: ohne doppelten Legenden-Eintrag
22.11.2019 08:08:20
Luschi
Hallo Toni,
bei mir klappt das so:
Sub Diagramm()
Dim cht As ChartObject, i As Integer, cont, rg2 As Range
Dim j As Integer, such As String, matsuch As Integer, rg1 As Range
Dim legText As String, legIndex As String, legArr As Variant
With Worksheets("Tabelle1")
Set rg1 = .Range("M1:M4")
Set rg2 = .Range("A2").CurrentRegion
End With
For Each cht In ActiveSheet.ChartObjects
cht.Delete
Next cht
Set cht = ActiveSheet.ChartObjects.Add(100, 100, 400, 250)
With cht.Chart
.ChartType = xlBarStacked
.SetSourceData Source:=rg2, PlotBy:=xlColumns
legText = "*": legIndex = "*"
For j = 1 To .SeriesCollection.Count
such = .SeriesCollection(j).Name
matsuch = Application.WorksheetFunction.Match(such, rg1, 0)
.SeriesCollection(j).Interior.ColorIndex = matsuch
If InStr(1, legText, such, vbTextCompare) = 0 Then
'Index der doppelten Einträge sammeln
'SerienCollection.Name = Teil der Legenden-Üverschrift
legText = legText & such & "*"
Else
'doppelte Eintrage (Index des Eintrags) sammeln
legIndex = legIndex & j & "*"
End If
Next j
.Legend.Clear
.HasLegend = True
.Legend.Position = xlLegendPositionTop
legArr = Split(legIndex, "*", -1, vbTextCompare)
For i = UBound(legArr) To LBound(legArr) Step -1 'rückwärts Array durchlaufen!
'vorwärts wird mit Löschung eines Legendeneintrags neu indiziert!
If legArr(i) "" Then
.Legend.LegendEntries(CInt(legArr(i))).Delete
End If
Next i
legText = "": legIndex = ""
If VarType(legArr) >= vbArray Then
Erase legArr
End If
'' legText = ""
'' For i = 1 To 4
'' cont = rg1.Cells(i, 1).Value
'' .Legend.LegendEntries(1).Item(1).Text = rg1.Cells(1, i).Value
'' .Legend.LegendEntries(1).MarkerBackgroundColorIndex = i
'' .SeriesCollection(i).Name = "=""" & cont & """"
'' .Legend.LegendEntries(i).LegendKey.Interior.ColorIndex = 11 + i
'' Next i
End With
End Sub
Gruß von Luschi
aus klein-Paris