Private Sub Drop_Down()
Dim SheetName As String
Dim ListName As String
Dim cColumn As String
Dim VColumn As String
Dim StartRow As Long
Dim EndRow As Long
Dim MyCell As Range
Dim kRow As Long
SheetName = "Lists"
ListName = "Drivers"
cColumn = "C"
VColumn = "D"
StartRow = 6
EndRow = 160
Sheets("Risk Category Checklist").Select
Set MyCell = Range(VColumn & StartRow)
MakeValidationList MyCell, ListName
MyCell.Select
Selection.Copy
Range(VColumn & StartRow & ":" & VColumn & EndRow).Select
Selection.PasteSpecial Paste:=xlPasteValidation, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
For kRow = StartRow To EndRow("C", "Risk Category Checklist")
If Cells(kRow, cColumn).Value = "" Then
Set MyCell = Range(VColumn & kRow)
RemoveValidation MyCell
End If
Next
End Sub
Sub MakeValidationList(MyCellRef As Range, ListName As String)
With MyCellRef.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & ListName
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Sub RemoveValidation(MyCellRef As Range)
With MyCellRef.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End Sub
Schon mal vielen, vielen Dank!
Corina