Option ExplicitFunction DATUMSABFRAGE() As String
Dim strDatum_vorher As String
Dim strDatum_Vorgabe As String
Dim strDatum_neu As String
Dim TT$, MM$, JJJJ$
Do Until strDatum_neu <> ""
If ActiveSheet.Range("A55").Value <> "" Then
strDatum_vorher = ActiveSheet.Range("A55").Value
strDatum_neu = Application.InputBox("Bitte geben Sie das Datum ein!" & vbCrLf & vbCrLf & vbCrLf & vbCrLf _
& "Eingetragenes Datum:", , _
strDatum_vorher)
Else
strDatum_Vorgabe = Date
strDatum_neu = Application.InputBox("Bitte geben Sie das Datum ein!" & vbCrLf & vbCrLf & vbCrLf & vbCrLf _
& "Vorschlag: heutiges Datum.", , _
strDatum_Vorgabe)
End If
If strDatum_neu = "Falsch" Then
DATUMSABFRAGE = ActiveSheet.Range("A55").Value
Exit Function
End If
If strDatum_neu = "" Then Exit Do
On Error Resume Next
TT = Left(strDatum_neu, InStr(strDatum_neu, ".") - 1)
MM = Left(Mid(strDatum_neu, Len(TT) + 2), InStr(Mid(strDatum_neu, Len(TT) + 2), ".") - 1)
If MM = "" Then MM = Mid(strDatum_neu, Len(TT) + 2)
JJJJ = Mid(Mid(strDatum_neu, Len(TT) + 2), Len(MM) + 2)
If Len(TT) = 1 Then TT = "0" & TT
If Len(MM) = 1 Then MM = "0" & MM
If Len(JJJJ) = 0 Then JJJJ = Format(Date, "yyyy")
If Len(JJJJ) = 1 Then JJJJ = Left(Format(Date, "yyyy"), 3) & JJJJ
If Len(JJJJ) = 2 Then JJJJ = Left(Format(Date, "yyyy"), 2) & JJJJ
strDatum_neu = TT & "." & MM & "." & JJJJ
If IsDate(strDatum_neu) = False Or _
Len(strDatum_neu) > 10 Or Len(TT) > 2 Or Len(MM) > 2 Or CInt(TT) > 31 Or _
CInt(MM) > 12 Or Len(JJJJ) = 3 Or Len(JJJJ) > 4 Then
MsgBox "Fehler bei der Eingabe des Datums!", _
vbExclamation, "Hinweis"
strDatum_neu = ""
End If
Loop
DATUMSABFRAGE = strDatum_neu
'und in den Tabellenblättern:
Private Sub Worksheet_Activate()
Range("A55").Value = DATUMSABFRAGE
blnInitialisierung = True 'Variable setzen um die Initialisierung der Userform bei Visible-Abfrage abzubrechen.
If Zeit.Visible = False Then 'Wenn Userform nicht angezeigt.
blnInitialisierung = False
Unload Zeit 'Userform Entladen. (Da sie beim abfragen initialisiert wird)
Exit Sub 'Abbrechen.
End If
Initialisierung False
blnInitialisierung = False
End Sub
Vielleicht kannst du damit was anfangen.
Gruß Mike