Liniendiagramm mit Beschriftung

Forumthread: Liniendiagramm mit Beschriftung

01.09.2015 12:40:12

Airwin

Hi Comunity,
jetzt habe ich noch ein Problem, ich habe ein Liniendiagramm, welches sich jede Woche erweitert. Nun möchte ich, den letzten sichtbaren Datenpunkt mit dem Datenreihennamen beschriften.
Gibt es hierfür eine raschere Lösung als jeden einzelnen Punkt anzuwählen + Datenbeschriftung hinzufügen?
Danke vorweg.
LG Airwin
https://www.herber.de/bbs/user/99942.xlsx

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Liniendiagramm mit Beschriftung

01.09.2015 14:04:32

Nepumuk
AW: Liniendiagramm mit Beschriftung

01.09.2015 14:15:50

Nepumuk
AW: Liniendiagramm mit Beschriftung

01.09.2015 15:05:55

Beverly
AW: Liniendiagramm mit Beschriftung

02.09.2015 11:19:09

Airwin

AW: Liniendiagramm mit Beschriftung

01.09.2015 14:04:32

Nepumuk

Hallo,
folgendes Makro nimmt dir die Arbeit ab:

Option Explicit

Public Sub Datenbeschriftung()

    Dim objSeries As Series, objPoint As Point
    Dim lngValueNumber As Long

    For Each objSeries In ThisWorkbook.Charts(1).SeriesCollection

        For Each objPoint In objSeries.Points

            With objPoint
                If .HasDataLabel Then .DataLabel.Delete
            End With
        Next

        With Tabelle2
            lngValueNumber = .Cells(objSeries.PlotOrder + 2, _
                .Columns.Count).End(xlToLeft).Column - 1
        End With

        With objSeries.Points(lngValueNumber)

            Call .ApplyDataLabels(Type:=xlDataLabelsShowValue)

            With .DataLabel
                .ShowValue = False
                .ShowSeriesName = True
            End With
        End With
    Next
End Sub

Gruß
Nepumuk

AW: Liniendiagramm mit Beschriftung

01.09.2015 14:15:50

Nepumuk

Option Explicit

Public Sub Datenbeschriftung()

    Dim objSeries As Series, objPoint As Point
    Dim lngValueNumber As Long

    For Each objSeries In ThisWorkbook.Charts(1).SeriesCollection

        For Each objPoint In objSeries.Points

            With objPoint
                If .HasDataLabel Then .DataLabel.Delete
            End With
        Next

        With Tabelle2
            lngValueNumber = .Cells(objSeries.PlotOrder + 2, _
                .Columns.Count).End(xlToLeft).Column - 1
        End With

        With objSeries.Points(lngValueNumber)
            Call .ApplyDataLabels(ShowSeriesName:=True, ShowValue:=False)
        End With
    Next
End Sub

AW: Liniendiagramm mit Beschriftung

01.09.2015 15:05:55

Beverly

Hi,
da für die Datenreihen der gesamte Zellbereich jeder Zeile ausgewählt ist, kann man die Datenpunkte vom letzten bis zum ersten in einer Schleife durchlaufen und prüfen, ob der Wert nicht leer ist - falls das der Fall ist, wird diesem Punkt die Datenbeschriftung hinzugefügt und dann die Schleife verlassen:

Sub Beschriftung()
Dim serReihe As Series
Dim lngPunkt As Long
Dim lngReihe As Long
Application.ScreenUpdating = False
With Charts("Diagramm1")
For lngReihe = 1 To .SeriesCollection.Count
Set serReihe = .SeriesCollection(lngReihe)
With serReihe
.ApplyDataLabels
.DataLabels.Delete
For lngPunkt = serReihe.Points.Count To 1 Step -1
If .Values(lngPunkt)  "" Then
.Points(lngPunkt).ApplyDataLabels
.Points(lngPunkt).DataLabel.ShowSeriesName = True
.Points(lngPunkt).DataLabel.ShowValue = False
Exit For
End If
Next lngPunkt
End With
Next lngReihe
End With
Set serReihe = Nothing
Application.ScreenUpdating = True
End Sub

AW: Liniendiagramm mit Beschriftung

02.09.2015 11:19:09

Airwin

funkt Super danke!
Airwin

Forumthread: Liniendiagramm mit Beschriftung

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread