How to get excel drop down list source in vba

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:

1. Cell B14 is changed and you want to update D14
2. 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:

1. Select first cell in column D that has the validation
2. 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:

1. Select all cells in column D that have validation
2. 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:

1. there is a first drop-down list in the proper cell and
2. 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