Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim RNG1 As Range, RNG2 As Range
Dim Hist As Integer, Anz As Integer, LR As Long
Dim T1 As String, Neu As String
Set RNG1 = Range("B1")
Set RNG2 = Range("B4")
Hist = 8
LR = Cells(Rows.Count, Hist).End(xlUp).Row
If Not Intersect(RNG1, Target) Is Nothing Then
If Target.Count = 1 Then
T1 = Target & "-" & Format(Date, "YY")
Anz = WorksheetFunction.CountIf(Columns(Hist), T1 & "*")
Neu = T1 & Format(Anz + 1, "000")
Application.EnableEvents = False
Cells(LR + 1, Hist) = Neu
RNG2 = Neu
Application.EnableEvents = True
End If
End If
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