Validation

Sub Macro16()
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateDate, AlertStyle:=xlValidAlertWarning, Operator _
        :=xlBetween, Formula1:="=TODAY()-10", Formula2:="=TODAY()+37"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = "Doh"
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Sub a()
Dim lVar_Calc
    Debug.Print Format(Now(), "hh:mm:ss")
    Application.ScreenUpdating = False
    lVar_Calc = Application.Calculation ''= xlManual
    Application.Calculation = xlManual
    
    ListValidation

    Application.Calculation = lVar_Calc
    Application.ScreenUpdating = True
    Debug.Print Format(Now(), "hh:mm:ss")

End Sub

'' ***************************************************************************
'' Purpose  : List validation details
'' Written  : 18-Feb-2003 by Andy Wiggins, Byg Software Limited
''
Sub ListValidation()
Dim twb As Workbook
Dim obAdd As Range
Dim nwb As Workbook
Dim lStr_AddOld As String
Dim lStr_AddNew As String
Dim lLng_ValCount As Long

    Set twb = ThisWorkbook
    Set obAdd = ActiveCell
    Set nwb = Workbooks.Add

    nwb.ActiveSheet.Name = "Data Validate - Settings"
    twb.Activate

    ''ActiveSheet.Cells(20, 1).CurrentRegion.Clear

Dim ws As Worksheet
Dim ce As Range

Dim lLng_Count As Long

    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    On Error Resume Next
    lLng_Count = 6
    lStr_AddOld = ""
    
    With nwb.ActiveSheet
        .Cells(lLng_Count, 1) = "Sheet"
        .Cells(lLng_Count, 2) = "Address"
        .Cells(lLng_Count, 3) = "Type"
        .Cells(lLng_Count, 4) = "AlertStyle"
        .Cells(lLng_Count, 5) = "Operator"
        .Cells(lLng_Count, 6) = "Formula1"
        .Cells(lLng_Count, 7) = "Formula2"
        .Cells(lLng_Count, 8) = "IgnoreBlank"
        .Cells(lLng_Count, 9) = "InCellDropdown"
        .Cells(lLng_Count, 10) = "InputTitle"
        .Cells(lLng_Count, 11) = "ErrorTitle"
        .Cells(lLng_Count, 12) = "InputMessage"
        .Cells(lLng_Count, 13) = "ErrorMessage"
        .Cells(lLng_Count, 14) = "ShowInput"
        .Cells(lLng_Count, 15) = "ShowError"

        .Cells(lLng_Count, 16) = "MergeArea.Address"
        .Cells(lLng_Count, 17) = "MergeArea.Cells.Count"
        .Cells(lLng_Count, 18) = "MergeArea.Rows.Count"
    End With
    
    
    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    For Each ws In Worksheets
        ws.Activate
        ''Selection.SpecialCells(xlCellTypeAllValidation).Select

        lLng_ValCount = ValidateCellsCount
        
        lLng_Count = lLng_Count + 1
        
        With nwb.ActiveSheet
            .Cells(lLng_Count, 1) = twb.ActiveSheet.Name
            .Cells(lLng_Count, 2) = "Validation Count"
            .Cells(lLng_Count, 3) = lLng_ValCount
        End With

        If lLng_ValCount > 0 Then
            For Each ce In Selection
                With nwb.ActiveSheet
    
                    lStr_AddNew = ce.MergeArea.Address
                    
                    If lStr_AddOld = lStr_AddNew Then
                    Else
                        lLng_Count = lLng_Count + 1
                        .Cells(lLng_Count, 1) = twb.ActiveSheet.Name
                        .Cells(lLng_Count, 2) = ce.Address
                        .Cells(lLng_Count, 3) = ce.Validation.Type
                        .Cells(lLng_Count, 4) = ce.Validation.AlertStyle
                        .Cells(lLng_Count, 5) = ce.Validation.Operator
                        .Cells(lLng_Count, 6) = "' " & ce.Validation.Formula1
                        .Cells(lLng_Count, 7) = "' " & ce.Validation.Formula2
                        .Cells(lLng_Count, 8) = ce.Validation.IgnoreBlank
                        .Cells(lLng_Count, 9) = ce.Validation.InCellDropdown
                        .Cells(lLng_Count, 10) = ce.Validation.InputTitle
                        .Cells(lLng_Count, 11) = ce.Validation.ErrorTitle
                        .Cells(lLng_Count, 12) = ce.Validation.InputMessage
                        .Cells(lLng_Count, 13) = ce.Validation.ErrorMessage
                        .Cells(lLng_Count, 14) = ce.Validation.ShowInput
                        .Cells(lLng_Count, 15) = ce.Validation.ShowError
    
                        .Cells(lLng_Count, 16) = ce.MergeArea.Address
                        .Cells(lLng_Count, 17) = ce.MergeArea.Cells.Count
                        .Cells(lLng_Count, 18) = ce.MergeArea.Rows.Count
                    End If
                End With
                lStr_AddOld = lStr_AddNew
            Next
        End If
    Next

    '' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    twb.Activate
    Application.GoTo Range(obAdd)

End Sub

Function ValidateCellsCount()
Dim lLng_Count As Long
    On Error GoTo error_ValidateCellsCount
    lLng_Count = 0
    Selection.SpecialCells(xlCellTypeAllValidation).Select
    lLng_Count = Selection.Count

error_ValidateCellsCount:
    ValidateCellsCount = lLng_Count
End Function