Question

我正在构建一个页面，其中Col H应该是一个依赖于Col A的下拉框。

Col A已设置为使用动态命名范围使用验证列表，该范围在名为Data的隐藏工作表上指定。

此外，在数据表中，我已经指定了3个依赖于Col A的列表，并且已经使它们成为动态命名范围。

到目前为止，在VB代码中，我有

从逗号A中的选择中取出逗号前的第一个单词，并将其用作我的“组”标识符。
将输入到Col B的所有文本（不相关）大写。

现在，我需要在Col H中指定要做的选项。您可以在“桌面”的情况下看到我尝试这样做，但是，它不起作用并且给我一个“对象必需”错误。

旧代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Columns(1)) Is Nothing Then
        If Target.Value <> "" And InStr(1, Target.Value, ",") Then
            Select Case Split(Target.Value, ",")(0)
               Case "Desktop": Range("H" & Target.row).Value = 
                    Data.Range("List_Desktops").Address
               Case "Laptop":  Range("H" & Target.row).Value = "Laptop"
               Case "Server":  Range("H" & Target.row).Value = "Server"
               Case Else:      Range("H" & Target.row).Value = "N/A"
            End Select
        End If
    ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
        If Not Target.HasFormula Then Target.Value = UCase(Target.Value)
    End If

LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

新守则：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, LastRow As Long, n As Long
    Dim MyCol As Collection
    Dim SearchString As String, TempList As String

    On Error GoTo Whoa

    Application.EnableEvents = False

     '~~> Find LastRow in List_Descriptions
    LastRow = Sheet2.Range("A" & Rows.Count).End(xlUp).row

    If Not Intersect(Target, Columns(1)) Is Nothing Then
        Set MyCol = New Collection

         '~~> Get the data from List_Descriptions into a collection
        For i = 1 To LastRow
            If Len(Trim(Sheet2.Range("A" & i).Value)) <> 0 Then
                On Error Resume Next
                MyCol.Add CStr(Sheet2.Range("A" & i).Value), CStr(Sheet2.Range("A" & i).Value)
                On Error GoTo 0
            End If
        Next i

        '~~> Create a list for the DV List
        For n = 1 To MyCol.Count
            TempList = TempList & "," & MyCol(n)
        Next

        TempList = Mid(TempList, 2)

        Range("A" & Target.row).ClearContents: Range("A" & Target.row).Validation.Delete

        '~~> Create the DV List
        If Len(Trim(TempList)) <> 0 Then
            With Range("A" & Target.row).Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    '~~> Capturing change in cell D1
    ElseIf Not Intersect(Target, Range("A" & Target.row)) Is Nothing Then
        SearchString = Range("A" & Target.row).Value

        TempList = FindRange(Sheet2.Range("A1:A" & LastRow), SearchString)

        Range("H" & Target.row).ClearContents: Range("H" & Target.row).Validation.Delete

        If Len(Trim(TempList)) <> 0 Then
            '~~> Create the DV List
            With Range("H" & Target.row).Validation
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=TempList
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    End If

    If Target.Value <> "" And InStr(1, Target.Value, ",") Then
        Select Case Split(Target.Value, ",")(0)
            Case "Desktop": Range("H" & Target.row).Value = "Desktop"
            Case "Laptop":  Range("H" & Target.row).Value = "Laptop"
            Case "Server":  Range("H" & Target.row).Value = "Server"
            Case Else:      Range("H" & Target.row).Value = "N/A"
        End Select
    End If
    ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
        If Not Target.HasFormula Then Target.Value = UCase(Target.Value)
    End If

LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

'~~> Function required to find the list from Col B
Function FindRange(FirstRange As Range, StrSearch As String) As String
    Dim aCell As Range, bCell As Range, oRange As Range
    Dim ExitLoop As Boolean
    Dim strTemp As String

    Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, _
    lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell
        strTemp = strTemp & "," & aCell.Offset(, 1).Value
        Do While ExitLoop = False
            Set aCell = FirstRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                strTemp = strTemp & "," & aCell.Offset(, 1).Value
            Else
                ExitLoop = True
            End If
        Loop
        FindRange = Mid(strTemp, 2)
    End If
End Function

示例练习册：https://docs.google.com/open?id=0B9ss2136xoWIVGxQYUJJX2xXc00

Answer 1

好吧，我明白了。非常感谢Siddharth Rout对此的帮助！对于那些可能希望将来查看代码的人来说，这里是：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Long, LastRow As Long, n As Long
    Dim MyCol As Collection
    Dim SearchString As String, TempList As String

    On Error GoTo Whoa

    Application.EnableEvents = False

If Not Intersect(Target, Columns(1)) Is Nothing Then
 If Not Intersect(Target, Range("A" & Target.row)) Is Nothing Then
    Range("H" & Target.row).ClearContents: Range("H" & Target.row).Validation.Delete

    If Target.Value <> "" And InStr(1, Target.Value, ",") Then
        Select Case Split(Target.Value, ",")(0)
            Case "Desktop"
                With Range("H" & Target.row).Validation
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=List_DesktopConfigs"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
           Case "Laptop"
                With Range("H" & Target.row).Validation
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=List_LaptopConfigs"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            Case "Server"
                With Range("H" & Target.row).Validation
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=List_ServerConfigs"
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            Case Else
                Range("H" & Target.row).Value = "N/A"
        End Select
    ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
        If Not Target.HasFormula Then Target.Value = UCase(Target.Value)
    End If
End If
End If

LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Function FindRange(FirstRange As Range, StrSearch As String) As String
    Dim aCell As Range, bCell As Range, oRange As Range
    Dim ExitLoop As Boolean
    Dim strTemp As String

    Set aCell = FirstRange.Find(what:=StrSearch, LookIn:=xlValues, _
    lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False)

    ExitLoop = False

    If Not aCell Is Nothing Then
        Set bCell = aCell
        strTemp = strTemp & "," & aCell.Offset(, 1).Value
        Do While ExitLoop = False
            Set aCell = FirstRange.FindNext(After:=aCell)

            If Not aCell Is Nothing Then
                If aCell.Address = bCell.Address Then Exit Do
                strTemp = strTemp & "," & aCell.Offset(, 1).Value
            Else
                ExitLoop = True
            End If
        Loop
        FindRange = Mid(strTemp, 2)
    End If
End Function

寻址Select Case中的动态命名范围

1 个答案: