dependent drop down list using VBA

Question

Basically I have two columns GrantNumber and IONames. I am trying to have a drop down menu (IONames) depending on another drop down menu (GrantNumber). So when a user puts his grantnumber and he goes to fill out IONames then only the ones that have to do with his GrantNumber need to show up in the IOName list or drop down menu.

I am getting a type mismatch error on:
If c.Value = ActiveSheet.Range("A2:A10000").Value Then 'selected GrantNumber

Any help is appreciated. Thanks

Sub SetupGrantNumber() 'run this on workbook open event
    Dim rng As Range
    Set rng = Worksheets("IOHealthcareLinkageTemplate").Range("A2:A10000")  'choose your cell(s) here
    With rng.Validation
        FRM = GetUniqueGrantNumbers()
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=FRM
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub


Sub SetupIOName()  'run this sub on the change event of GrantNumber cell
    Dim rng As Range
    Set rng = Worksheets("IOHealthcareLinkageTemplate").Range("B2:B10000")  'choose your cell(s) here
    With rng.Validation
        FRM = GetIONames()
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=FRM
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub


Function GetUniqueGrantNumbers() As String
    Dim sOut As String
    Dim v, c
    Dim rngList As Range

    Set rngList = Worksheets("IOs").Range("A2:A10000") 'edit the range where your GrantNumber list is stored
    sOut = ""

    For Each c In rngList
        If InStr(1, sOut, c.Value & ",") = 0 Then  'check if the value is already in the upload list and add if not there
            sOut = c.Value & "," & sOut
        End If
    Next c
    'remove first ,
    If sOut <> "" Then
        sOut = Left(sOut, Len(sOut) - 1)
    End If
    GetUniqueGrantNumbers = sOut
End Function


Function GetIONames() As String
    Dim sOut As String
    Dim v, c
    Dim rngSearch As Range

    Set rngSearch = Worksheets("IOs").Range("C2:C10000") 'edit the range where  your IOname list exists
    sOut = ""

    For Each c In rngSearch
        If c.Value = ActiveSheet.Range("A2:A10000").Value Then 'selected GrantNumber
            sOut = sOut & "," & ActiveSheet.Range("E" & c.Row).Value
        End If
    Next c
    'remove first ,
    If sOut <> "" Then
        sOut = Mid(sOut, 2)
    End If
    GetIONames = sOut
End Function

Asger Asger · Accepted Answer · 2019-01-25T20:46:02

Please place following code in ThisWorkbook. SetupGrantNumber may additionally be started manually or by button or whatever as it collects all grantnumbers for data validation in column A:

Private Sub Workbook_Open()
    Call SetupGrantNumber
End Sub

The 2 directly related subs can be placed in a module:

Sub SetupGrantNumber()
    FRM = GetUniqueGrantNumbers()
    If FRM <> "" Then
        With Worksheets("IOHealthcareLinkageTemplate").Range("A2:A10000").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=FRM
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If
End Sub

Function GetUniqueGrantNumbers() As String
    Dim sOut As String
    Dim c As Range
    sOut = ""
    With Worksheets("IOs")
        For Each c In .Range("A2:A10000")
            If InStr(1, sOut, c.Value & ",") = 0 Then
                sOut = c.Value & "," & sOut
            End If
        Next c
    End With
    If sOut <> "" Then
        sOut = Left(sOut, Len(sOut) - 1)
    End If
    GetUniqueGrantNumbers = sOut
End Function

Following code has to be placed within "ThisWorkbook" also, as it automatically checks, if any cell within Range A:A is changed. Then Excel automatically runs SetupIOName with the changed cell's value:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim MonitoredCells As Range
    Dim c As Range
    If Sh.Name = "IOHealthcareLinkageTemplate" Then
        Set MonitoredCells = Intersect(Target, Target.Parent.Range("A:A"))
        If Not MonitoredCells Is Nothing Then
            For Each c In MonitoredCells
                If c.Value <> "" Then SetupIOName (c.Value)
            Next c
        End If
    End If
End Sub

Following subs can be placed together with above mentioned SetupGrantNumber and a GetUniqueGrantNumbers in the same module:

Sub SetupIOName(ByRef SelectedGrantNumber As String)
    FRM = GetIONames(SelectedGrantNumber)
    If FRM <> "" Then
        With Worksheets("IOHealthcareLinkageTemplate").Range("B2:B10000").Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:=FRM
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If
End Sub

Function GetIONames(ByRef SelectedGrantNumber As String) As String
    Dim sOut As String
    Dim c As Range
    sOut = ""
    With Worksheets("IOs")
        For Each c In .Range("A2:A10000")
            If c.Value = SelectedGrantNumber Then
                sOut = sOut & "," & .Cells(c.Row, "C").Value
            End If
        Next c
    End With
    If sOut <> "" Then
        sOut = Mid(sOut, 2)
    End If
    GetIONames = sOut
End Function

dependent drop down list using VBA

1 Answers