HERBERS Excel-Forum - das Archiv
Thema: Liniendiagramm mit Beschriftung
Liniendiagramm mit Beschriftung
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
AW: Liniendiagramm mit Beschriftung
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
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
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
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
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
Airwin
funkt Super danke!
Airwin
Liniendiagramm mit Beschriftung
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
AW: Liniendiagramm mit Beschriftung
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
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
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
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
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
Airwin
funkt Super danke!
Airwin
Dialog-Beispiele
Excel-Beispiele