A Build Validation Form

[jstiene]

I have a form that builds validation in a column while retaining cells original values
It only needs two buttons and three textboxes

I put my cursor in the header row of the column to build the list or set validation but you cold replace Hrow and Ccol with anything you want

A Listbutton to pull all the values in a column into a textbox called ValidationList
A BuildButon that loops down the column the cursor is in retaining the value, but building validation lists from the ValidationList textbox, (which could also be typed manually)
And a InputBox textbox where you could add an input message to the validation
And a ErrorBox textbox where you can add an error message to the validation

Private Sub ListButton_Click() 'Create list from column
Dim i As Integer, Lrow As Long, Cval As String, Add1 As String
Dim St2 As String, Ccol As Integer, Hrow As Integer
Hrow = Selection.Row
Ccol = Selection.Column
Lrow = Cells(Hrow, Ccol).SpecialCells(xlLastCell).Row
For i = Hrow + 1 To Lrow
Cval = Cells(i, Ccol).value
If InStr(1, St2, Cval, vbTextCompare) = 0 Then
St2 = St2 & Cval & ", "
End If
Next i
St2 = Left(St2, Len(St2) - 2)
Me.ValidationList.value = St2
End Sub

Private Sub BuildButton_Click() 'Build Validation
Dim i As Integer, Lrow As Long, Cval As String, Add1 As String
Dim LV As String, Ccol As Integer, Hrow As Integer, SH1 As String
LV = Me.ValidationList.value
SH1 = ActiveSheet.Name
Hrow = Selection.Row
Ccol = Selection.Column
Lrow = Cells(Hrow, Ccol).SpecialCells(xlLastCell).Row
For i = Hrow + 1 To Lrow
Cval = Cells(i, Ccol).value
Add1 = Cells(i, Ccol).Address(False, False)
If Len(LV) > 0 Then
With ActiveWorkbook.Sheets(SH1).Range(Add1).Validation
.Delete
.Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=LV
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
If Len(Me.ErrorBox.value) = 0 Then
.ErrorMessage = ""
Else
.ErrorMessage = Me.ErrorBox.value
End If

If Len(Me.InputBox.value) = 0 Then
.InputMessage = ""
Else
.InputMessage = Me.InputBox.value
End If


.ShowInput = True
.ShowError = True
End With
ActiveWorkbook.Sheets(SH1).Range(Add1).value = Cval
End If
Next i
MsgBox "Column has the same values but validation has been added."
End Sub