Public Sub DatumManuell(ByVal Target As Range)
Dim Eingabe As String
Dim TempDatum As String
Dim EchtesDatum As Date
Dim Datum As Date
Dim i As Integer
Dim jahr As Integer
Dim monat As Integer
Dim tag As Integer
jahr = year(Date)
monat = month(Date)
tag = day(Date)
Eingabe = Trim(Target.Value)
Application.EnableEvents = False
' Fall 1: Eingabe hat bereits Punkte
If InStr(Eingabe, ".") > 0 Then
' Überprüfen ob ein oder mehrere Punkte in der Eingabe sind
If IsNumeric(Eingabe) Then
Dim eingabeteil As String
Dim teileliste As Variant
teileliste = Split(Eingabe, ".")
For i = 0 To UBound(teileliste)
eingabeteil = teileliste(i)
If eingabeteil <> "" And IsNumeric(eingabeteil) Then
If i = 0 Then
tag = eingabeteil
ElseIf i = 1 Then
monat = eingabeteil
ElseIf i = 2 Then
jahr = eingabeteil
Else
MsgBox "Eingabe ist kein Datum !!!"
Application.EnableEvents = False
Target.Value = ""
Target.Select
Application.EnableEvents = True
Exit Sub
End If
End If
Next
Datum = DateSerial(jahr, monat, tag)
Application.EnableEvents = False
Target.Value = Datum
Target.Offset(0, 2).Select
Application.EnableEvents = True
Exit Sub
End If
' Fall 2: Eingabe ist genau 6-stellig ohne Punkte (z.B. 010126)
Else
If Len(Eingabe) = 6 And IsNumeric(Eingabe) Then
TempDatum = Left(Eingabe, 2) & "." & Mid(Eingabe, 3, 2) & "." & Right(Eingabe, 2)
If IsDate(TempDatum) Then
Target.Value = CDate(TempDatum)
Target.NumberFormat = "dd.mm.yy"
Else
GoTo FehlerMeldung
End If
FehlerMeldung:
MsgBox "Datum nur im Format TTMMJJ oder TT.MM.JJ eingeben", vbCritical, "Fehler Datum"
Target.ClearContents
Application.EnableEvents = True
If tag = 0 Or tag > 31 Then
'MsgBox "Der Tag liegt außerhalb des gültigen Bereichs! (1 - 31)", vbExclamation, "Fehler Datum"
'Application.EnableEvents = False
'Target.Value = ""
'Target.Select
'Application.EnableEvents = True
Exit Sub
ElseIf monat = 0 Or monat > 12 Then
'MsgBox "Der Monat liegt außerhalb des gültigen Bereichs! (1 - 12)", vbExclamation, "Fehler Datum"
'Application.EnableEvents = False
'Target.Value = ""
'Target.Select
'Application.EnableEvents = True
Exit Sub
End If
' Gültigkeit prüfen
On Error Resume Next
Datum = DateSerial(jahr, monat, tag)
On Error GoTo 0
If IsDate(Datum) Then
Application.EnableEvents = False
Target = Datum
Target.Offset(0, 2).Select
Application.EnableEvents = True
End If
End If
End If
End SubOption Explicit
Public ZelleAlt As String
Public FormatAlt As String
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
If Target.CountLarge = 1 Then
Application.EnableEvents = False
Target.NumberFormat = "dd.mm.yy"
If Target.Value Like "##.##.##" Or Target.Value Like "##.##.####" Then
Target.FormulaLocal = Target.Value
ZelleAlt = ""
Target.Offset(0, 2).Select
ElseIf Target.Value Like "######" Then
Target.FormulaLocal = Format(Target.Value, "00\.00\.00")
ZelleAlt = ""
Target.Offset(0, 2).Select
Else
Target.NumberFormat = FormatAlt
Target.Formula = Target.Formula
End If
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ZelleAlt <> "" Then
Range(ZelleAlt).NumberFormat = FormatAlt
ZelleAlt = ""
End If
If Target.Column = 1 Then
If Target.CountLarge = 1 Then
ZelleAlt = Target.Address(0, 0)
FormatAlt = Target.NumberFormat
Target.NumberFormat = "@"
End If
Else
ZelleAlt = ""
End If