Office 2010: Beschriftung Diagramm basierend nur auf eingeblendeten Zellen

[Joe94]

Hallo zusammen!

Ich habe ein Makro geschrieben zur Erzeugung eines Punktdiagramms, welches durch zwei Zellen beschriftet wird. Einmal dem ersten Buchstaben des Vor- und des Nachnamens.
Solange ich meine Tabelle nicht filtere passen die Beschriftungen, sobald ich jedoch dieses filtere zerschießt es die Beschriftungen. Ich habe auch die Hidden Eigenschaft versucht, komme dabei aber nicht zum gewünschten Ergebnis. Hätte jemand eine Idee, wie ich den richtigen Bezug zu den lediglich eingeblendeten Daten herstelle? Vielen Dank im Voraus!

Zunächst der "alte Code" der nur für die ungefilterte Tabelle funktioniert

Code: [Auswählen]

'Erzeugung des Graphen und Zuweisung der Daten aus dem Tabellenblatt "Gehaltsdaten"

Sub ErzeugungGraph()

   
Dim data As Worksheet
Dim name As Range
Set data = ActiveWorkbook.Worksheets("Gehaltsdaten")

Application.ScreenUpdating = False
Worksheets("Gehaltsdaten").Activate
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatter
ActiveChart.SetSourceData Source:=data.Range("A3:AC3000")

ActiveChart.SeriesCollection.NewSeries

    With ActiveChart.SeriesCollection(1)
   
        .XValues = "=Gehaltsdaten!$G$3:$G$800"
        .Values = "=Gehaltsdaten!$AC$3:$AC$800"
        .name = "=Gehaltsdaten!$B$3:$B$800"
        .Trendlines.Add Type:=xlLinear
       
    End With
   
ActiveChart.location Where:=xlLocationAsObject, _
   name:=ThisWorkbook.Worksheets(4).name
   
'Formatierung des Graphen
   
    With ActiveChart
   
        .PlotArea.Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .HasLegend = False
        .Parent.Height = 600
        .Parent.Width = 1200
        .HasTitle = True
        .HasTitle = False
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Alter"
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "JEK 35H"
        .Axes(xlValue).MinimumScale = 0
        .Axes(xlCategory).MaximumScale = 80
        .SeriesCollection(1).Format.Fill.ForeColor.RGB = rgbBlue
   
       
    End With
   
Worksheets(4).ChartObjects(1).Activate

With ActiveChart

    .Axes(xlValue).AxisTitle.Font.Size = 20
    .Axes(xlCategory).AxisTitle.Font.Size = 20
    .PlotArea.Interior.ColorIndex = 15
   
End With

'Aufrufen des Programms zur Beschriftung der Datenpunkte

      Call BeschriftungDiagramm
       
End Sub

'Beschriftet die Datenpunkte mit je dem ersten Buchstaben des Nach- und Vornamens

Sub BeschriftungDiagramm()

Dim lngPunkt As Long
Dim data As Worksheet


Set data = ActiveWorkbook.Worksheets("Gehaltsdaten")

                                   
   With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
      .ApplyDataLabels
     
      For lngPunkt = 1 To .Points.Count
     
         .Points(lngPunkt).DataLabel.Text = Left(data.Cells(lngPunkt + 2, 2), 1) & " " & Mid(data.Cells(lngPunkt + 2, 3), 2, 1)
     
     
      Next lngPunkt
     
   End With
                                   
End Sub

Sub LöschenDiagramm()
    ActiveSheet.ChartObjects(1).Delete
End Sub


Hier nun der Eigenversuch, der jedoch in der Form nicht funktioniert.

Code: [Auswählen]

Sub XBeschriftungTest()

Dim lngPunkt As Long
Dim data As Worksheet
Dim zeileMax As Integer


Set data = ActiveWorkbook.Worksheets("Gehaltsdaten")
zeileMax = ActiveWorkbook.Worksheets("Gehaltsdaten").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
                                   
   With ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
      .ApplyDataLabels
           
     
      For lngPunkt = 1 To zeileMax
     
        If data.Rows(lngPunkt).Hidden = True Then GoTo Ausgeblendet Else GoTo Eingeblendet
       
Eingeblendet:
         .Points(lngPunkt).DataLabel.Text = Left(data.Cells(lngPunkt + 2, 2), 1) & " " & Mid(data.Cells(lngPunkt + 2, 3), 2, 1)
               
     
     
Ausgeblendet:
      Next
     
     
     
   End With
                                   
End Sub