Sub Dropdown() Dim x As Long, y As Long Dim objCell As Range Dim objDataRangeStart As Range Dim objDataRangeEnd As Range Dim rangename As String ' >> Set The Range For Valid Data Set wsSourceList = Sheets("Sheet2") Set wsDestList = Sheets("Sheet1") Set objDataRangeStart = wsSourceList.Cells(1, 2) 'Start range for dropdown list entries Set objDataRangeEnd = wsSourceList.Cells(6, 2) 'End range for dropdown list entries MsgBox objDataRangeStart MsgBox objDataRangeEnd '================= With Worksheets("Sheet2") Range(objDataRangeStart, objdatarangaeend).Name = "rangename" End With '===================== ' >> Set Validation On Required Cell 'Set objCell = wsDestList.Cells(8, 4) 'Location of the dropdown list 'MsgBox objCell x = 4 y = 6 Do Set objCell = wsDestList.Cells(x, y) 'Location of the dropdown list With objCell.Validation .Delete '.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & objDataRangeStart.Address & ":" & objDataRangeEnd.Address '=========================================== .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=rangename" '================================================================ .IgnoreBlank = True .InCellDropdown = True .ErrorTitle = "Warning" .ErrorMessage = "Please select a value from the list available in the selected cell." .ShowError = True End With x = x + 1 'y = y + 1 Loop Until x = 51 End Sub
DON'T MISS