change InputTitle and InputMessage in columns from row 2 thru 1000
 

Hello,

I have 60 columns and 1000 rows with column title in row 1.

How would I adapt the following code to specify a different InputMessage
(IM) and InputTitle (IT) for each column row2 to 1000? Each cell in the
column (except row 1) has the same IT and IM. Or, does it need totally
separate code?

Specifically, is there a way to do it without writing 60 blocks of code?
Perhaps by specifying a cell range for IT and IM on another sheet? There are
columns not specified in the ranges below because they are not yes/no.

Thanks in advance,
John

Sub YESNOValidate()

Dim Choices As String
Choices = "Yes, No"

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range, r5 As Range, r6
As Range, r7 As Range, myMultiAreaRange As Range
Worksheets("Data entry sheet").Activate
Set r1 = Range("F2:L1000")
Set r2 = Range("N2:T1000")
Set r3 = Range("W2:AE1000")
Set r4 = Range("AH2:AJ1000")
Set r5 = Range("AL2:AS1000")
Set r6 = Range("AU2:AX1000")
Set r7 = Range("AZ2:BH1000")
Set myMultiAreaRange = Union(r1, r2, r3, r4, r5, r6, r7)
myMultiAreaRange.Select


With Selection.Validation
.Delete
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Choices
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "IT"
.ErrorTitle = "ET"
.InputMessage = "IM"
.ErrorMessage = "Please Input Yes or No, case sensitive"
.ShowInput = True
.ShowError = True
End With
End Sub