How to get excel drop down list source in vba - excel

Question

Im using VBA code to create multiple selection drop down list. The code will make each drop down list in target cell become multuple selection list with function:
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo Exitsub
The source of drop down list in target cell is =indirect(b14), and b14 is another drop down list (single selection). Now if b14's value will become list1, Id like to make my target's cell list become multiple selection list. In any other case I want it work in normal excel way. I've tried to precache the list source with if Evaluate(Target.Validation.Formula1) = "=list1" then
but I get mismatch error for Evaluate(Target.Validation.Formula1).
How can I do it?
EDIT:
There are some example screenshots from my worksheet, not to misunderstand it's construction.
A1:A5 named range list1, B1:B5 named range list2, B14 data validation list =list1
D14 data validation list with =INDIRECT(B14) formula

Answer 1

First of all, using the Worksheet_Change event means that every worksheet change is going to run your code, so Target could be any range not just B14. The assumption that you can use the Target.Validation.Formula1 property on any cell is wrong because cells that do not have validation will not have this property available.
Secondly, you are doing this:
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo Exitsub
I believe that you are making the assumption that this is referring to cells within the Target range but it really refers to all the cells with validation within the entire sheet. Try this code to clarify that:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngValidation As Range
Set rngValidation = Target.SpecialCells(xlCellTypeAllValidation)
Debug.Print Target.Address
If Not rngValidation Is Nothing Then Debug.Print rngValidation.Address
End Sub
You can see in your Immediate window that no matter what cell you are editing the rngValidation will always point to all the validation cells within the worksheet.
Thirdly, you are doing this:
If Evaluate(Target.Validation.Formula1) = "=list1"
which won't work because Evaluate("=Indirect(B14)") simply returns an array and not a String as you are assuming.
Finally, if I read the question I understand that you want the list in cell D14 to be changed based on value in B14 but you keep referring to the Target as D14. If B14 is changed then B14 is the Target, not D14. D14 can only be the Target if you change D14. That's just how the Event works.
Since I am not clear on what you want, I am assuming two scenarios:
Cell B14 is changed and you want to update D14
Cell D14 is selected and you want the list to be updated before you click the dropdown
Scenario 1 - Cell B14 is changed and you want to update D14 (or other cells)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
If rngCell.Validation.Formula1 = "=List1" Then
Debug.Print rngCell.Address & " - Validation: " & rngCell.Validation.Formula1
'Do whatever logic you need to update other cells linking to this one
'
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub
Scenario 2 - Cell D14 (or equivalent) is selected and you want the list to be updated before you click the dropdown
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Dim rngList As Range
Dim listFound As Boolean
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
Set rngList = Nothing
Set rngList = Evaluate(rngCell.Validation.Formula1)
listFound = False
If Not rngList Is Nothing Then
listFound = (rngList.Name.Name = "List1")
End If
If listFound Then
Debug.Print rngCell.Address & " - list found"
'Do whatever logic you need to update rngCell
'
'
Else
Debug.Print rngCell.Address & " - list not found"
'Do whatever logic you need to update rngCell
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub
EDIT 1
You can use the following code to translate formulas:
Private Function TranslateFormulaToUS(ByVal formulaText As String) As String
On Error Resume Next
With GetBlankEditableCell
.Formula2Local = formulaText
TranslateFormulaToUS = .Formula
.Formula = vbNullString
End With
On Error GoTo 0
End Function
Private Function GetBlankEditableCell() As Range
Dim wSheet As Worksheet
Static blankCell As Range
'
'Re-use, if still blank
If Not blankCell Is Nothing Then
If IsEmpty(blankCell.Value2) Then
Set GetBlankEditableCell = blankCell
Exit Function
End If
End If
'
'Find a Blank cell
For Each wSheet In ThisWorkbook.Worksheets
Set blankCell = GetEditableBlankCellFromSheet(wSheet)
If Not blankCell Is Nothing Then Exit For
Next wSheet
Set GetBlankEditableCell = blankCell
End Function
Private Function GetEditableBlankCellFromSheet(wSheet As Worksheet) As Range
Dim rngBlanks As Range
Dim rngCell As Range
'
On Error Resume Next
Set rngBlanks = wSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rngBlanks Is Nothing Then Set rngBlanks = wSheet.Cells(1, 1)
'
'Check if Worksheet is Macro Protected
If (wSheet.ProtectContents Or wSheet.ProtectDrawingObjects _
Or wSheet.ProtectScenarios) And Not wSheet.ProtectionMode _
Then
For Each rngCell In rngBlanks
If Not rngCell.Locked Is Nothing Then
Set GetEditableBlankCellFromSheet = rngCell
Exit Function
End If
Next rngCell
Else
Set GetEditableBlankCellFromSheet = rngBlanks.Cells(1, 1)
End If
End Function
And now you can replace something like:
Set rngList = Evaluate(rngCell.Validation.Formula1)
with:
Set rngList = Evaluate(TranslateFormulaToUS(rngCell.Validation.Formula1))
EDIT 2
If you would like to avoid the translation mentioned in EDIT 1 then you could use a dynamic relative named range as mentioned in the comments.
Let's start with the current layout (I presume I got it right):
Named range List1 is a local scope range:
Named range List2 is also a local scope range:
The B column (rows could vary from sheet to sheet) has data validation set to List1:
Let's create a third named range called RemoteDV:
Select first cell in column D that has the validation
Create a LOCAL named range and add the formula =INDIRECT(Sheet1!$B8) (or whatever row you are on - i.e. first row in both B and D column that has validation - I have 8 here). NOTE! Do not use an absolute address (i.e. locking the row with =INDIRECT(Sheet1!$B$8)) because we want the named range to work for the entire D column
Now, let's link the new named range to validation:
Select all cells in column D that have validation
Link to the named range you have just created
The end result is that you do not have to translate the formula anymore.
You also do not need Evaluate anymore:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Dim rngList As Range
Dim listFound As Boolean
Dim formulaText As String
Dim nameList As Name
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
Set rngList = Nothing
formulaText = rngCell.Validation.Formula1
If Left$(formulaText, 1) = "=" Then
formulaText = Right$(formulaText, Len(formulaText) - 1)
End If
Set nameList = Nothing
Set nameList = rngCell.Worksheet.Names(formulaText)
Set rngList = nameList.RefersToRange
listFound = False
If Not rngList Is Nothing Then
listFound = (rngList.Name.Name = "'" & rngList.Worksheet.Name & "'!" & "List1") _
Or (rngList.Name.Name = rngList.Worksheet.Name & "!" & "List1")
End If
If listFound Then
Debug.Print rngCell.Address & " - list found"
'Do whatever logic you need to update rngCell
'
'
Else
Debug.Print rngCell.Address & " - list not found"
'Do whatever logic you need to update rngCell
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub

Answer 2

EDIT:
Below is a simple block of code that should do what you need. First, I created a data validation drop down in cell A1. Next, I created a list named List1 and pointed it to a range of values. Next, I set the List -> Formula of the data validation to be =INDIRECT(B14). And finally I entered the text List1 in cell B14.
I ran the below test script to see what my output was.
Sub Test()
Dim rangeWithDropdown As Range
Set rangeWithDropdown = Sheets("Sheet1").Range("A1")
Debug.Print rangeWithDropdown.Validation.Formula1
Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name
Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name = ThisWorkbook.Names("List1").Value
End Sub
My output was the following:
=INDIRECT(B14)
=Sheet1!$D$1:$D$4
True
When requesting the formula alone, it returns =INDIRECT(B14). When evaluating the formula, and returning the name, it returns the range that I established. And finally, when testing for equality against the named range, it returns true.
Is my understanding correct? Can you try running this code against your workbook (update the data validation cell reference), and then tell me which line throws an error?
END EDIT
The reason that your code isn't working is that Evaluate(=indirect(B14)) does not return the name of the range, but rather the address of the range. So, if List1 refers to Range("A1:A10"), then the Evaluate function will return Sheet1!Range("A1:A10"). When you try comparing a string ("list1") to a range, you get the type mismatch error.
One option is to compare the range returned against the expected range of "List1". For example, the following code might work:
If evaluate(activecell.validation.formula1).name = activeworkbook.Names("List1").Value

Answer 3

I see there has been a lot of work by others. I didn't want to "steal" their solutions so i didn't read them completely. I hope my contribution won't be out of place. I humbly proceed to post my answer.
If in the column with the first drop-down lists (column B) the said drop-down list are already present, then our "List1" outcome will be a possible value. This solution checks if such value is "List1" and creates the second drop-down list accodingly:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Declarations.
Dim DblStartingRow As Double
Dim DblEndingRow As Double
Dim RngFirstDropDownList As Range
Dim RngSecondDropDownList As Range
Dim RngRange01
Dim StrTrigger As String
''''''''''''''''''''''''''''
'VARIABLES SETTINGS - Start'
''''''''''''''''''''''''''''
'StrTrigger will be the value that if found in the first drop down _
list will trigger the creation of the second drop down list.
StrTrigger = "List1"
'DblStartingRow is the first row that will possibly contain one of _
our drop down list.
DblStartingRow = 14
'DblStartingRow is the last row that will possibly contain one of _
our drop down list.
DblEndingRow = Rows.Count
'Setting RngFirstDropDownList and RngSecondDropDownList to match _
the entire columns where our lists of drop-down lists will be found.
Set RngFirstDropDownList = Range("B:B")
Set RngSecondDropDownList = Range("D:D")
''''''''''''''''''''''''''
'VARIABLES SETTINGS - End'
''''''''''''''''''''''''''
'Resetting RngSecondDropDownList to cover only the rows we need to _
cover according to DblStartingRow and DblEndingRow
Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
'Checking if Target intersects with RngSecondDropDownList. If there _
is no intersection, the subroutine is terminated. Otherwise RngRange01 _
is set as such intersection.
On Error Resume Next
Set RngRange01 = Intersect(Target, RngSecondDropDownList)
On Error GoTo 0
If RngRange01 Is Nothing Then Exit Sub
'Covering each cell in RngRange01
For Each RngSecondDropDownList In RngRange01
'Setting RngFirstDropDownList as the cell in the column of first _
drop-down lists at the same row of our (possible) second drop-down _
list.
Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
'Focusing RngSecondDropDownList.
With RngSecondDropDownList.Validation
'Removing validation.
.Delete
'Checking if RngFirstDropDownList contains StrTrigger.
If RngFirstDropDownList.Formula = StrTrigger Then
'Adding the dropdown list.
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End If
End With
Next
End Sub
To be put in the sheets' module, it will activate everytime the selection is changed. If the selection intersect with the range with the second drop-down list, it will insert such drop-down list for each cell in said intersection. Works for single and multiple cell selection. I've set every possible parameter i could think of as a variable that can be changed in the first part of the subroutine after declarations. This should do what the question was asking.
Then again, if the question wanted the second drop-down list to be created only when:
there is a first drop-down list in the proper cell and
said first drop-down list had a specific Validation.Formula1
then the code i'd suggest is this one:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Declarations.
Dim DblStartingRow As Double
Dim DblEndingRow As Double
Dim RngFirstDropDownList As Range
Dim RngSecondDropDownList As Range
Dim RngRange01
Dim StrTrigger As String
Dim StrValidation As String
''''''''''''''''''''''''''''
'VARIABLES SETTINGS - Start'
''''''''''''''''''''''''''''
'StrTrigger will be the formula that if found in Validation.Formula1 _
of the first drop-down list will trigger the creation of the second _
drop down list.
StrTrigger = "=List1"
'DblStartingRow is the first row that will possibly contain one of _
our drop down list.
DblStartingRow = 14
'DblStartingRow is the last row that will possibly contain one of _
our drop down list.
DblEndingRow = Rows.Count
'Setting RngFirstDropDownList and RngSecondDropDownList to match _
the entire columns where our lists of drop-down lists will be found.
Set RngFirstDropDownList = Range("B:B")
Set RngSecondDropDownList = Range("D:D")
''''''''''''''''''''''''''
'VARIABLES SETTINGS - End'
''''''''''''''''''''''''''
'Resetting RngSecondDropDownList to cover only the rows we need to _
cover according to DblStartingRow and DblEndingRow
Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
'Checking if Target intersects with RngSecondDropDownList. If there _
is no intersection, the subroutine is terminated. Otherwise RngRange01 _
is set as such intersection.
On Error Resume Next
Set RngRange01 = Intersect(Target, RngSecondDropDownList)
On Error GoTo 0
If RngRange01 Is Nothing Then Exit Sub
'Covering each cell in RngRange01
For Each RngSecondDropDownList In RngRange01
'Setting RngFirstDropDownList as the cell in the column of first _
drop-down lists at the same row of our (possible) second drop-down _
list.
Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
'Focusing RngSecondDropDownList.
With RngSecondDropDownList.Validation
'Removing validation.
.Delete
'Checking if RngFirstDropDownList contains a drop-down list _
based on StrTrigger.
On Error GoTo CP_No_Drop_down_List
If RngFirstDropDownList.Validation.Formula1 = StrTrigger Then
'Adding the dropdown list.
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End If
CP_No_Drop_down_List:
On Error GoTo 0
End With
Next
End Sub
This code is similar to the previous one but it will in fact check if there is a first drop-down list based on the Validation.Formula1 specified. Note that if you want the second drop-down list be created acconding to StrTrigger and not to the actual indirect reference of the first drop-down list value, you can substitute the line
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
with the line
Formula1:=StrTrigger