Dim usedTarget As Integer 'переменная, с помощью которой я прекращаю зацикливание события изменения'

Private Sub Worksheet_Change(ByVal Target As Range)
    usedTarget = usedTarget + 1
    IIf usedTarget > 1, 0, 1
    EnableEvents = True
    If Target.Cells.Count > 1 Then Exit Sub
        If Not Intersect(Target, Range("Дата")) Is Nothing Then
            Call CheckДата(Target)
            GoTo PasswordOn
        End If
End Sub


Private Sub CheckДата(Target As Range)
If usedTarget <> 1 Then Exit Sub
    Dim StrVal As String, dDate As Date
    If Target.Value <> "" Then
        If IsDate(Target.Value) Then
            With Target
                StrVal = Format(.Text, "000000")
                If IsNumeric(StrVal) And Len(StrVal) = 6 Then
                    On Error GoTo DateError
                    dDate = DateValue(Left(StrVal, 2) & "/" & Mid(StrVal, 3, 2) & "/" & Right(StrVal, 2))
                    If dDate < CDate("01.01.2000") Then GoTo DateError
                        .Value = CStr(dDate)
                        Exit Sub
DateError:
                    dDate = StrVal
                    .Value = CStr(dDate)
                End If
            End With
        Else
            MsgBox "А вот такое значение: [ " & Target.Value & " ] вводить нельзя.", 48, "Фиг вам!"
            Target.Value = ""
            Target.Select
        End If
    End If
End Sub