Sub НАЙТИ_ДАТУ()
    Dim r As Range
    On Error Resume Next
        Set r = ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If Not r Is Nothing Then
        Dim c As Range
        For Each c In r
            If IsDate(c) Then
                r.Parent.Range("A1:A100").Value = Int(c.Value)
                Exit For
            End If
        Next
    End If
End Sub