Clever-Excel-Forum

Hallo Fans,
ich möchte über Datengültigkeitsabfrage nur Datumseingaben kleiner oder gleich heute zulassen, also keine Datumseingaben, die in der Zukunft liegen.
Wenn ich dann bei der Einstellung Datenüberprüfung bei Zulassen die Funktion "Datum" eingebe und bei Daten den Abgleich "kleiner oder gleich" sowie als Enddatum die Funktion "=("heute")" eingebe, gibt es die Fehlermeldung "Das für das Enddatum eingegebene Datum ist ungültig".
Was mache ich falsch bzw. kann ich als Enddatum überhaupt heute definieren?
Gibt es eventuell die Möglichkeit, morgen also heute plus einen Tag zu definieren und liegt darin die Lösung? Huh

Danke für eure Hilfe.
Gruß longjohn

Hallo,

Annahme: Die Werte sollen in A1 bis A10 eingegeben und geprüft werden.

Den Bereich A1 bis A10 markieren - Die Datenüberprüfung aufrufen - Zulassen: Benutzerdefiniert - Formel: =A1<=Heute() - OK

Beachte aber, dass damit eine Eingabe eines Datums in der Zukunft über C&P immer noch möglich ist.

Hallo zusammen,

eine weitere Möglichkeit wäre:

Code:
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Er

    Dim ErrorCount As Long

    If Intersect(Range("A1:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row), Target) Is Nothing Then Exit Sub

    Application.EnableEvents = False

    Select Case Target.Cells.Count

        Case 1

            If ActiveSheet.Cells(Target.Row, Target.Column) > Date Then

                MsgBox "Nur Datum 'kleiner gleich Heute' zulässig.", vbInformation, "Hinweis"

                ActiveSheet.Cells(Target.Row, Target.Column) = ""

            End If

        Case Else

            Dim i As Long

            For i = 0 To Target.Cells.Count - 1

                If ActiveSheet.Cells(Target.Row + i, Target.Column) > Date Then

                    ActiveSheet.Cells(Target.Row + i, Target.Column) = ""

                    ErrorCount = ErrorCount + 1

                End If

            Next i

            If ErrorCount > 0 Then

                MsgBox "Nur Datum 'kleiner gleich Heute' zulässig." & vbCrLf & _

                       "Es wurden nicht alle Daten übernommen.", vbInformation, "Hinweis"

            End If

    End Select

Ex:

    Application.EnableEvents = True

    Exit Sub

Er:

    Application.Cursor = xlDefault

    Application.EnableEvents = True

    Dim sErr As String

    sErr = "Fehlermeldung/Information..." & vbCrLf & vbCrLf

    sErr = sErr & "Fehlernummer: " & vbTab & Err.Number & vbCrLf & vbCrLf

    sErr = sErr & "Beschreibung: " & vbCrLf & Err.Description

    MsgBox sErr, vbCritical, "Sub: Worksheet_Change in Tabelle1"

    Resume Ex

    'For debug:

    Resume

End Sub

Hier werden Eingaben größer 'Heute' gelöscht und auch Fehleingaben über CopyPaste verhindert.
Den Code bei Deinem aktuellen Excelsheet hinterlegen und die Targetrange bitte anpassen. Im Moment reagiert diese auf Eingaben in Spalte A.

Dies ist nur als Beispiel gedacht und natürlich sehr verbesserungswürdig.

Gruß Carsten

Besten Dank an Euch alle. Gruß Hajo

longjohnexcel

Peter

DbSam

longjohnexcel