AW: Diagramm Datenquelle ?
21.03.2008 14:12:00
fcs
Hallo Heinz,
nach etwas vorösterlicher Bastelarbeit funktioniert es jetzt.
Für etwas mehr Flexibilität hab ich eine Sub geschrieben, die mit Parametern aufgerufen wird.
Je nachdem ob das Diagramm eingebettet ist oder auf einem separaten Blatt sieht die aufrufende Prozedur ein wenig anders aus.
Gruß
Franz
Option Explicit
Sub DiagrammLabelsA()
'Eingebettetes Diagramm beschriften
Dim ws As Worksheet
Set ws = Worksheets("Tab1")
Call ReiheBeschriften(Diagramm:=ws.ChartObjects(1).Chart, iReihe:=3, iOffset:=-2)
Set ws = Nothing
End Sub
Sub DiagrammLabelsB()
'Separates Diagramm beschriften
Call ReiheBeschriften(Diagramm:=Charts("Diagramm1"), iReihe:=3, iOffset:=-2)
End Sub
Sub ReiheBeschriften(Diagramm As Chart, iReihe As Integer, iOffset As Integer)
'Datenreihe in Säulendiagramm zusätzlich mit Inhalten aus 2. Zellbereich beschriften
'Diagramm = das zu bearbeitenden Diagramm
'iReihe = Nummer der Datenreihe deren Beschriftung angepasst werden soll
'iOffset = Offset (relativ zur Datenspalte der Reihe) der Spalte mit dem Text
Dim Punkt As Point, Reihe As Series, Bereich As Range
Dim arrTemp() As String, strTemp As String, iI%, iJ%
Set Reihe = Diagramm.SeriesCollection(iReihe)
'Formeltext der Datenreihe auflösen und in Array schreiben
'=SERIES(,,Tab1!$B$2:$E$20,3)
For iI = 9 To Len(Reihe.Formula) - 1
Do Until Mid(Reihe.Formula, iI, 1) = ","
strTemp = strTemp & Mid(Reihe.Formula, iI, 1)
iI = iI + 1
If iI > Len(Reihe.Formula) - 1 Then Exit Do
Loop
iJ = iJ + 1
ReDim Preserve arrTemp(1 To iJ)
arrTemp(iJ) = strTemp
strTemp = ""
Next
'arrTemp(1) = Name bzw. Bereich mit Name der Reihe
'arrTemp(2) = Liste bzw. Bereich mit X-Werten der Reihe
'arrTemp(3) = Liste bzw. Bereich mit Y-Werten der Reihe
'arrTemp(4) = Nr der Datenreihe
'Blattname
strTemp = Left(arrTemp(3), InStr(1, arrTemp(3), "!") - 1)
With Worksheets(strTemp)
'Datenbereich der Datenreihe
strTemp = Mid(arrTemp(3), InStr(1, arrTemp(3), "!") + 1)
Set Bereich = .Range(strTemp)
End With
Application.ScreenUpdating = False
'Datenbeschriftung zusammensetzen aus Text in Spalte iOffset Spalten _
links/rechts der Datenreihe und dem Wert des Datenpunktes
For iI = 1 To Reihe.Points.Count
Set Punkt = Reihe.Points(iI)
Punkt.HasDataLabel = True
Punkt.DataLabel.Text = Bereich(iI, 1).Offset(0, iOffset).Text & " " _
& Format(Bereich(iI, 1).Value, Bereich(iI, 1).NumberFormat)
Next
Application.ScreenUpdating = True
Set Bereich = Nothing
Set Punkt = Nothing: Set Reihe = Nothing: Set Diagramm = Nothing
End Sub