Mehrdeutiger Name: Worksheet_Change

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wks As Worksheet
Dim vRow As Variant, iRow As Integer
Application.ScreenUpdating = False
If Target.Column <> 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
Cancel = True
Set wks = Worksheets("Termine")
vRow = Application.Match(CDbl(Target.Value), wks.Columns(1), 0)
If IsError(vRow) Then
Beep
MsgBox "An diesem Tag keinen Termin gefunden!"
Exit Sub
End If
iRow = 2
Do Until IsEmpty(wks.Cells(iRow, 1))
If CDbl(wks.Cells(iRow, 1).Value) = CDbl(Target.Value) Then
wks.Cells(iRow, 3).Value = 1
Else
wks.Cells(iRow, 3).Value = 2
End If
iRow = iRow + 1
Loop
wks.Range("A1").CurrentRegion.Sort key1:=wks.Range("C2"), order1:=xlAscending, header:=xlYes
' wks.Columns(3).ClearContents
Application.Goto wks.Range("A1"), True
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim var As Variant
If Target.Column <> 4 Then Exit Sub
With Application
var = .VLookup(Target.Value, _
Worksheets("Training").Columns("A:B"), 2, 0)
If Not IsError(var) Then
Target.Offset(0, 1) = .VLookup(Target.Value, _
Worksheets("Training").Columns("A:B"), 2, 0) '
End If
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim var As Variant
If Target.Column <> 6 Then Exit Sub
With Application
var = .VLookup(Target.Value, _
Worksheets("Strecke").Columns("A:B"), 2, 0)
If Not IsError(var) Then
Target.Offset(0, 1) = .VLookup(Target.Value, _
Worksheets("Strecke").Columns("A:B"), 2, 0)
End If
End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim var As Variant
If Target.Column <> 8 Then Exit Sub
With Application
var = .VLookup(Target.Value, _
Worksheets("Schuhe").Columns("A:B"), 2, 0)
If Not IsError(var) Then
Target.Offset(0, 8) = .VLookup(Target.Value, _
Worksheets("Schuhe").Columns("A:B"), 2, 0)
End If
End With
End Sub