Kommentarcode umstellen

Private Sub Worksheet_Change(ByVal Target As Range) Dim Zelle As Range For Each Zelle In Intersect(Target, Columns(2)) If Zelle.Column = 2 Then Select Case Zelle.Text Case "" On Error Resume Next Zelle.Offset(0, -1).Comment.Delete On Error GoTo 0 Case Else On Error GoTo Kommentar_erstellen Zelle.Offset(0, -1).Comment.Text Text:=Zelle.Text On Error GoTo 0 End Select End If Next Exit Sub Kommentar_erstellen: Zelle.Offset(0, -1).AddComment Resume End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rngC As Range For Each rngC In Intersect(Target, Columns("R")) Select Case rngC.Text Case "" On Error Resume Next Cells(rngC.Row, "K").Comment.Delete On Error GoTo 0 Case Else On Error GoTo Kommentar_erstellen Cells(rngC.Row, "K").Comment.Text Text:="Stichtag: " & rngC.Text On Error GoTo 0 End Select Next Exit Sub Kommentar_erstellen: Cells(rngC.Row, "K").AddComment Resume End Sub

Hallo Erich,
erneut herzlichen Dank für Deine Rückmeldung; Beim Testen des Codes stelle ich fest, dass er nur dann läuft, wenn aktuell wohl eine Eingabe erfolgt, versuche ich, bereits in Spalte R enthaltene Daten in den Kommentar zu bekommen, erscheint (wahrscheinlich so auch logisch) Fehlermeldung, dass Objekt erforderlich. Ich stelle mir vor, dass der Code beim Öffnen der Mappe läuft (verlagere das also in Workbook_Open, weil dadurch auch schon die Spalte R automatisch gefüllt wird) und dann die Kommentare erstellt. Da war dann wohl ein Gedankenfehler von mir.- Wäre der Code so umstellbar, dass ich ihn in ein Modul kopiere und ihn dann bei Workbook_Open oder evtl. auf Schaltfläche laufen lasse, so dass er dann die bereits in Spalte R enthaltenen Daten übernimmt? - Danke schon jetzt wieder für Deine Rückmeldung.
Gruß - Wolfgang

Hi Wolfgang,
die Fehlermeldung "Objekt erforderlich..." kommt von meinem Programmierfehler.
(Das Exit Sub gleich zu Beginn fehlte.)
Außerdem habe ich noch die Spaltenbuchstaben durch Zahlen und das Select Case durch ein If ersetzt.
Hier eine neue Version der Change-Prozedur:


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngB As Range, rngC As Range
If Intersect(Target, Columns("R")) Is Nothing Then Exit Sub
For Each rngC In Intersect(Target, Columns("R"))
If rngC.Text = "" Then
On Error Resume Next
Cells(rngC.Row, 11).Comment.Delete
On Error GoTo 0
Else
On Error GoTo Kommentar_erstellen
Cells(rngC.Row, 11).Comment.Text Text:="Stichtag: " & rngC.Text
On Error GoTo 0
End If
Next
Exit Sub
Kommentar_erstellen:
Cells(rngC.Row, "K").AddComment
Resume
End Sub

Und hier die Version, die du per Button oder so aufrufen kannst und die die Spalte R abarbeitet.
Ein Manko:
Kommentare in "K" unterhalb des letzten Eintrags in "R" werden nicht gelöscht.


Option Explicit
Sub KommAusR()
Dim rngC As Range
With Sheets("Tabelle1") ' evtl. anpassen
For Each rngC In .Cells(1, 18).Resize(.Cells(.Rows.Count, 18).End(xlUp).Row)
If rngC.Text = "" Then
On Error Resume Next
.Cells(rngC.Row, 11).Comment.Delete
On Error GoTo 0
Else
On Error GoTo Kommentar_erstellen
.Cells(rngC.Row, 11).Comment.Text Text:="Stichtag: " & rngC.Text
On Error GoTo 0
End If
Next
Exit Sub
Kommentar_erstellen:
.Cells(rngC.Row, 11).AddComment
Resume
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rngC As Range ' Sp.18 = R If Intersect(Target, Columns(18)) Is Nothing Then Exit Sub For Each rngC In Intersect(Target, Columns(18)) If rngC.Text = "" Then On Error Resume Next Cells(rngC.Row, 11).Comment.Delete ' Sp.11 = K On Error GoTo 0 Else On Error GoTo Kommentar_erstellen Cells(rngC.Row, 11).Comment.Text Text:="Stichtag: " & rngC.Text On Error GoTo 0 End If Next Exit Sub Kommentar_erstellen: Cells(rngC.Row, 11).AddComment Resume End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread