寻址动态命名范围内的选择案例

我建立一个页面，山口^ h应该是一个下拉框，这是依赖于山口A.寻址动态命名范围内的选择案例

柱A已经建立使用动态验证列表使用命名范围是在名为Data的隐藏表上指定的。

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

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

采取的第一个字，一个逗号前，从柱A所做的选择和使用，作为我的“集团”标识。
大写输入到栏B（不相关）的所有文本。

现在，我需要指定什么使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

来源

2012-07-13 Josh McKearin

你要删除的验证，在“H”列并重新创建它，如在这个环节上的http：// siddharthrout。 wordpress.com/2011/07/29/excel-data-validationcreate-dynamic-dependent-lists-vba/ – 2012-07-13 14:34:16

对我来说这似乎过于复杂。 – 2012-07-13 14:40:02

也许它看起来“过于复杂”，但事实并非如此。你有一个示例工作簿，我可以看到哪些隐藏的命名范围？ – 2012-07-13 15:01:56

好吧，我想通了。非常感谢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

来源

2012-07-13 18:02:03

寻址动态命名范围内的选择案例

回答

相关问题