Gültiges Datum (ohne Punkteingabe)

Hallo Forumsmitglieder,
nochmal das beliebte Thema Datumseingabe ohne Punkt.
Mit folgendem Code versuche ich eine Datumseingabe in einer Zelle:
Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range Dim Datum As String Set Bereich = Range("C8") If Not Intersect(Target, Bereich) Is Nothing Then ' Zelle ist im Bereich Application.EnableEvents = False If Len(Target) = 6 Then Datum = Left(Target, 2) & "." & Mid(Target, 3, 2) & "." & Right(Target, 2) Sheets("Eingabedaten").Range("B3") = Datum 'nur zum Testen Datum = Format(Datum, "dd.mm.yyyy") Sheets("Eingabedaten").Range("D3") = Datum 'nur zum Testen If IsDate(Datum) Then Target = Format(Datum, "dd.mm.yyyy") Else Target = Empty Target.Activate End If End If Application.EnableEvents = True End If End Sub
------------------
Das läuft auch wie vorgesehen, wenn sinnvolle Eingaben wie 180404 gemacht werden. Wird jedoch ein ungültiges Datum wie 290203 eingegeben, versagt der Code, es wird gnadenlos ein anderes (über Format) erzeugt. Sieht jemand eine Möglichkeit, die Gültigkeit des eingegebenen Datums vor der Umwandlung mit Format zu erkennen, ohne dass ich ellenlangen eigenen Plausi-Code erstellen muss?
Jürgen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range Dim Datum As Date Set Bereich = Range("C8") If Not Intersect(Target, Bereich) Is Nothing Then ' Zelle ist im Bereich Application.EnableEvents = False If Len(Target) = 6 Then Datum = DateSerial(Right(Target, 2), Mid(Target, 3, 2), Left(Target, 2)) Sheets(1).Range("B3") = Datum 'nur zum Testen Datum = Format(Datum, "dd.mm.yyyy") Sheets(1).Range("D3") = Datum 'nur zum Testen If IsDate(Datum) Then Target = Format(Datum, "dd.mm.yyyy") Else Target = Empty Target.Activate End If ElseIf Len(Target) = 5 Then Datum = DateSerial(Right(Target, 2), Mid(Target, 2, 2), Left(Target, 1)) Sheets(1).Range("B3") = Datum 'nur zum Testen Datum = Format(Datum, "dd.mm.yyyy") Sheets(1).Range("D3") = Datum 'nur zum Testen If IsDate(Datum) Then Target = Format(Datum, "dd.mm.yyyy") Else Target = Empty Target.Activate End If End If Application.EnableEvents = True End If End Sub

Hallo Jürgen,
und hier eine Variante mit VBA:
"Features"
Eingabe 4 Stellen -> Jahr = aktuelles Jahr
geprüft wird:
Monat muss zwischen 1 und 12 liegen
Tag muss gültig sein ( d.h. zwischen 1 und Ultimo liegen )
Option Explicit


Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target(1)
If .Address(0, 0) = "C8" Then
Application.EnableEvents = False
.Value = Input2Date(.Value)
.NumberFormatLocal = "TT.MM.JJJJ"
If .Value = 0 Then
.Value = ""
Target.Select
End If
Application.EnableEvents = True
End If
End With
End Sub


Private Function Input2Date(strDatum As String) As Date
Dim tag     As Byte
Dim mon     As Byte
Dim jahr    As Integer
Dim strTit  As String
strTit = "Falsche Datumsangabe"
On Error Resume Next
'If VarType(WorksheetFunction.Text(strDatum, "00-00-0000") + 0) = vbDate Then
Input2Date = CDate(WorksheetFunction.Text(strDatum, "00-00-0000"))
If VarType(Input2Date) = vbDate And Input2Date > 0 Then
Exit Function
End If
On Error GoTo 0
If Len(strDatum) > 4 Then
jahr = Val(Right(strDatum, Len(strDatum) - 4))
Else
jahr = Year(Date)
End If
If Len(strDatum) > 5 Then strDatum = Left(strDatum, 4)
If Len(strDatum) < 3 Then
MsgBox "Datum muss mindestens 3 Stellen haben!" _
& vbCr & "Eingabe war aber: " & strDatum, _
vbCritical + vbOKOnly, _
strTit
Exit Function
End If
mon = Val(Right(strDatum, 2))
If mon > 13 Or mon = 0 Then
MsgBox "Eingegebenen Monat gibt es nicht", _
vbCritical + vbOKOnly, _
strTit
Exit Function
End If
tag = Val(Mid(strDatum, 1, Len(strDatum) - 2))
If tag = 0 Or tag > Day(DateSerial(jahr, mon + 1, 0)) Then
MsgBox "Diesen Tag gibt es im Monat " _
& vbCr & vbCr & WorksheetFunction.Text("01." & mon & "." & jahr, "MMMM") _
& vbCr & vbCr & "nicht!", _
vbCritical + vbOKOnly, _
strTit
End If
Input2Date = DateSerial(jahr, mon, tag)
End Function


Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Address(0, 0) <> "C8" Then Exit Sub
With Target
Application.EnableEvents = False
.NumberFormat = "0"
.ClearContents
Application.EnableEvents = True
End With
End Sub

Servus aus dem Salzkammergut
Franz

Private Sub Worksheet_Change(ByVal Target As Excel.Range) With Target(1) If .Address(0, 0) = "C8" Then Application.EnableEvents = False .Value = Input2Date(.Value) .NumberFormatLocal = "TT.MM.JJJJ" If .Value = 0 Then .Value = "" Target.Select End If Application.EnableEvents = True End If End With End Sub

Private Function Input2Date(strDatum As String) As Date Dim tag As Byte Dim mon As Byte Dim jahr As Integer Dim strTit As String strTit = "Falsche Datumsangabe" On Error Resume Next 'If VarType(WorksheetFunction.Text(strDatum, "00-00-0000") + 0) = vbDate Then Input2Date = CDate(WorksheetFunction.Text(strDatum, "00-00-0000")) If VarType(Input2Date) = vbDate And Input2Date > 0 Then Exit Function End If On Error GoTo 0 If Len(strDatum) > 4 Then jahr = Val(Right(strDatum, Len(strDatum) - 4)) Else jahr = Year(Date) End If strDatum = Left(strDatum, IIf(Len(strDatum) > 5, 4, 3)) If Len(strDatum) < 3 Then MsgBox "Datum muss mindestens 3 Stellen haben!" _ & vbCr & "Eingabe war aber: " & strDatum, _ vbCritical + vbOKOnly, _ strTit Exit Function End If mon = Val(Right(strDatum, 2)) If mon > 13 Or mon = 0 Then MsgBox "Eingegebenen Monat gibt es nicht", _ vbCritical + vbOKOnly, _ strTit Exit Function End If tag = Val(Mid(strDatum, 1, Len(strDatum) - 2)) If tag = 0 Or tag > Day(DateSerial(jahr, mon + 1, 0)) Then MsgBox "Diesen Tag gibt es im Monat " _ & vbCr & vbCr & WorksheetFunction.Text(CDate("01." & mon & "." & jahr), "MMMM") _ & vbCr & vbCr & "nicht!", _ vbCritical + vbOKOnly, _ strTit Exit Function End If Input2Date = DateSerial(jahr, mon, tag) End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Target.Address(0, 0) <> "C8" Then Exit Sub With Target Application.EnableEvents = False .NumberFormat = "0" .ClearContents Application.EnableEvents = True End With End Sub

Beliebteste Forumthreads (12 Monate)

Gültiges Datum (ohne Punkteingabe)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Gültiges Datum (ohne Punkteingabe)

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread