AW: Noch ein Problem
19.08.2009 11:56:54
Matthias5
Hi,
zu 1):
Dann bestehen Formelbezüge zwischen den beiden Blättern, richtig? Dann wäre das eine Möglichkeit:
Public ws As Worksheet
Sub Datenbeschriftung()
Dim Beschriftungen As Range, c As Range, i As Long
Application.ScreenUpdating = False
Set Beschriftungen = Range("A35:A105").SpecialCells(xlCellTypeVisible)
Sheets("Fahrscheinart im Quervergleich").Activate
ActiveSheet.ChartObjects(1).Activate
For Each c In Beschriftungen
i = i + 1
With ActiveChart.SeriesCollection(1).Points(i)
.HasDataLabel = True
.DataLabel.Text = c.Value
End With
Next c
ws.Activate
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_Calculate()
Set ws = ActiveSheet
Datenbeschriftung
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
For Each c In Target
If Not Intersect(c, Range("A35:A105")) Is Nothing Then Datenbeschriftung
Next c
End Sub
zu 2):
Richtig, die Bereiche müssen dann angepasst werden.
Alternativ könnte man "Datenbeschriftung" im allgemeinen Modul ablegen und die Range beim Aufruf übergeben:
In das Klassenmodul des jeweiligen Tabellenblattes (Bereich jeweils anpassen):
Private Sub Worksheet_Calculate()
Set ws = ActiveSheet
Call Datenbeschriftung(Range("A35:A105"))
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
For Each c In Target
If Not Intersect(c, Range("A35:A105")) Is Nothing Then Call Datenbeschriftung(Range("A35: _
A105"))
Next c
End Sub
In ein allgemeines Modul:
Public ws As Worksheet
Sub Datenbeschriftung(bereich As Range)
Dim Beschriftungen As Range, c As Range, i As Long
Application.ScreenUpdating = False
Set Beschriftungen = bereich.SpecialCells(xlCellTypeVisible)
Sheets("Fahrscheinart im Quervergleich").Activate
ActiveSheet.ChartObjects(1).Activate
For Each c In Beschriftungen
i = i + 1
With ActiveChart.SeriesCollection(1).Points(i)
.HasDataLabel = True
.DataLabel.Text = c.Value
End With
Next c
ws.Activate
Application.ScreenUpdating = True
End Sub
Gruß,
Matthias