Als Antwort auf diesen Beitrag
Hallo an alle Hilfsbereiten,
ich bin mal wieder mit meinem Latein am Ende. Wenn in der entsprechenden Zelle das Datum eingetragen wird, soll das immer im Format "TT.MM.JJ" erscheinen. Unabhängig davon, ob es ttmmjj oder tt.mm.jj eingegeben wird. Anschließend soll bei Betätigen der TAB-Taste der Cursor zwei Zellen weiter nach rechts springen. Im beigefügten Makro funktioniert der Fall 1 (Eingabe tt.mm.jj), bei Fall 2 (Eingabe als ttmmjj) bin ich am verzweifeln. Kann mir da jemand helfen?
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 Sub