Question

基本上，我有两列GrantNumber和IONames。我试图根据另一个下拉菜单（GrantNumber）创建一个下拉菜单（IONames）。因此，当用户放置他的授权号并填写IOName时，只有那些与他的GrantNumber有关的名称才需要显示在IOName列表或下拉菜单中。

我在以下位置收到类型不匹配错误：
如果c.Value = ActiveSheet.Range（“ A2：A10000”）。Value然后“选择了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

使用VBA的依赖下拉列表

1 个答案: