Private Sub Worksheet_Change(ByVal Target As Range)
    If Target = 0 Then Exit Sub
    Dim D4 As String
    Dim D8 As Date
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("D3:D33")) Is Nothing Then
       With Target
          D4 = Format(.Text, "0000")
          If Val(Left(D4, 2)) = 0 Or Val(Left(D4, 2)) > 31 Then MsgBox "Так низзя!!!": Exit Sub
          If Val(Mid(D4, 3, 2)) = 0 Or Val(Mid(D4, 3, 2)) > 12 Then MsgBox "Так низзя!!!": Exit Sub
          If IsNumeric(D4) And Len(D4) = 4 Then
             Application.EnableEvents = False
             D8 = DateValue(Left(D4, 2) & "/" & Mid(D4, 3, 2) & "/" & Year(Date))
             .NumberFormat = "dd/mm/yyyy"
             .Value = CDate(DateSerial(Year(D8), Month(D8), Day(D8)))
          End If
        End With
     End If
     Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target = 0 Then Exit Sub
   Dim D4 As String
   Dim D8 As Date
   If Target.Cells.Count > 1 Then Exit Sub
   If Not Intersect(Target, Range("D3:D33")) Is Nothing Then
     With Target
       D4 = Format(.Text, "0000")
       If IsNumeric(D4) And Len(D4) = 4 Then
         If IsDate(Left(D4, 2) & "/" & Mid(D4, 3, 2) & "/" & Year(Date)) Then
            Application.EnableEvents = False
            D8 = DateValue(Left(D4, 2) & "/" & Mid(D4, 3, 2) & "/" & Year(Date))
            .NumberFormat = "dd/mm/yyyy"
            .Value = CDate(DateSerial(Year(D8), Month(D8), Day(D8)))
         Else
            MsgBox "Нет такой даты!"
         End If
       End If
     End With
   End If
   Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim s$, form$
If Target.Count > 1 Then Exit Sub
form$ = Target.NumberFormatLocal
s = Target.Value
If InStr(1, form, ".") = 0 Then Exit Sub
'If Not Target.NumberFormat = "m/d/yyyy" Then Exit Sub ' можно так - если используется только такой формат даты
If InStr(1, s, ",") = 0 Then Exit Sub
If UBound(Split(s, ",")) <> 2 Then Exit Sub
s = Replace(s, ",", ".")
If Right(s, 1) = "." Then s = s & Year(Now)
If IsDate(s) Then Target = Format(s, "dd.mm.yyyy")
End Sub