зависимый выпадающий список с использованием VBA

Question

В основном у меня есть два столбца GrantNumber и IONames.Я пытаюсь получить раскрывающееся меню (IONames) в зависимости от другого раскрывающегося меню (GrantNumber).Поэтому, когда пользователь вводит свой номер гранта, и он собирается заполнить IONames, в списке или выпадающем меню IOName должны отображаться только те, которые имеют отношение к его GrantNumber.

Я получаю несоответствие типовошибка:
Если c.Value = ActiveSheet.Range ("A2: A10000"). Значение Затем "выбран" GrantNumber

Любая помощь приветствуется.Спасибо

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

Answer 1

Пожалуйста, введите следующий код в ThisWorkbook.SetupGrantNumber может быть дополнительно запущен вручную или по кнопке или как угодно, поскольку он собирает все номера грантов для проверки данных в столбце A:

Private Sub Workbook_Open()
    Call SetupGrantNumber
End Sub

2 непосредственно связанные подпрограммы могут быть размещены в модуле:

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

Следующий код также должен быть помещен в «ThisWorkbook», так как он автоматически проверяет, была ли изменена какая-либо ячейка в диапазоне A: A.Затем Excel автоматически запускает SetupIOName со значением измененной ячейки:

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

Следующие подпрограммы могут быть размещены вместе с вышеупомянутыми SetupGrantNumber и GetUniqueGrantNumbers в одном и том же модуле:

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