Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range
Set C = Range("A2:A100") 'Bereich anpassen!
With Target
If Not Intersect(Target, C) Is Nothing Then
If .Count = 1 Then
.Offset(0, 1) = Now
End If
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column Mod 2 > 0 Then
Target.Offset(, 1) = IIf(Target "", Now, "")
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim Rng As Range, Zelle
Set Rng = Range("A1:H100") 'Hier löst das Makro aus
If Not Intersect(Rng, Target) Is Nothing Then
Application.EnableEvents = False
If Target.Count = 1 Then
If Target.Column Mod 2 = 1 Then 'ungerade
If Target "" Then
Target.Offset(0, 1) = Format(Now, "YYYY.MM.DD hhmmss")
Else
Target.Offset(0, 1).ClearContents
End If
Else
MsgBox "Keine Eingabe möglich"
Application.Undo
End If
Else
MsgBox "Zellen einzeln bearbeiten"
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim C As Range
Set C = Range("A2:A100, C2:C100, E2:E100, G2:G100, I2:I100") 'Bereich anpassen!
With Target
If Not Intersect(Target, C) Is Nothing Then
If .Count = 1 Then
.Offset(0, 1) = Now
End If
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim Rng As Range, Zelle
Set Rng = Range("A1:A100") 'Hier löst das Makro aus
If Not Intersect(Rng, Target) Is Nothing Then
Application.EnableEvents = False
For Each Zelle In Intersect(Rng, Target)
If Zelle "" Then
Zelle.Offset(0, 1) = Format(Now, "YYYY.MM.DD hhmmss")
Else
Zelle.Offset(0, 1).ClearContents
End If
Next
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Const Eingabezellen = "A2:A99"
Dim Zelle As Range
If Not Intersect(Target, Range(Eingabezellen)) Is Nothing Then
Application.EnableEvents = False
For Each Zelle In Intersect(Target, Range(Eingabezellen))
If IsEmpty(Zelle) Then
Zelle.Offset(0, 1).ClearContents
Else
Zelle.Offset(0, 1) = Now
End If
Next
Application.EnableEvents = True
End If
End Sub