使用VBA的从属下拉列表

Question

如果c.value=activeSheet.range（“A2:A10000”）。value然后“selected 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还可以通过手动或按按钮或其他方式启动，因为它收集所有grantnumbers以用于A列中的数据验证：

Private Sub Workbook_Open()
    Call SetupGrantNumber
End Sub

两个直接相关的子模块可以放在一个模块中：

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

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