Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RaBereich1 As Range
Dim RaZelle1 As Range
Set RaBereich1 = Range("A1:A1006")
Set RaBereich1 = Intersect(RaBereich1, Range(Target.Address))
If Not RaBereich1 Is Nothing Then
Application.EnableEvents = False
For Each RaZelle1 In Range(Target.Address)
With RaZelle1
If (Len(.Value2) = 6 Or Len(.Value2) = 5) _
And IsNumeric(.Value2) Then
If Len(.Value2) = 6 Then
.Value = CDate(Mid(.Value2, 1, 2) _
& "." & Mid(.Value2, 3, 2) & "." _
& Mid(.Value2, 5, 2))
ElseIf Len(.Value2) = 5 Then
.Value = CDate(Mid(.Value2, 1, 1) _
& "." & Mid(.Value2, 2, 2) & "." _
& Mid(.Value2, 4, 2))
End If
.NumberFormat = "dd/mm/yy;@"
Application.EnableEvents = True
ElseIf (Len(.Value2) = 8 Or Len(.Value2) = 7) _
And IsNumeric(.Value2) Then
If Len(.Value2) = 8 Then
.Value = CDate(Mid(.Value2, 1, 2) _
& "." & Mid(.Value2, 3, 2) & "." _
& Mid(.Value2, 5, 4))
ElseIf Len(.Value2) = 7 Then
.Value = CDate(Mid(.Value2, 1, 1) _
& "." & Mid(.Value2, 2, 2) & "." _
& Mid(.Value2, 4, 4))
End If
.NumberFormat = "dd/mm/yyyy;@"
Application.EnableEvents = True
Else
.NumberFormat = "0"
End If
End With
Next RaZelle1
Application.EnableEvents = True
End If
Set RaBereich1 = Nothing
Dim RaBereich2 As Range
Dim RaZelle2 As Range
Set RaBereich2 = Range("B1:B1006")
Set RaBereich2 = Intersect(RaBereich2, Range(Target.Address))
If Not RaBereich2 Is Nothing Then
Application.EnableEvents = False
For Each RaZelle2 In Range(Target.Address)
With RaZelle2
If (Len(.Value2) = 6 Or Len(.Value2) = 5) _
And IsNumeric(.Value2) Then
If Len(.Value2) = 6 Then
.Value = CDate(Mid(.Value2, 1, 2) _
& ":" & Mid(.Value2, 3, 2) & ":" _
& Mid(.Value2, 5, 2))
ElseIf Len(.Value2) = 5 Then
.Value = CDate(Mid(.Value2, 1, 1) _
& ":" & Mid(.Value2, 2, 2) & ":" _
& Mid(.Value2, 4, 2))
End If
.NumberFormat = "hh:mm:ss"
Application.EnableEvents = True
Else
.NumberFormat = "0"
End If
End With
Next RaZelle2
Application.EnableEvents = True
End If
Set RaBereich2 = Nothing
End Sub
Sub AusfüllenSpalteC()
With Intersect(Range("C1:C1006"), ActiveSheet.UsedRange)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub