excel - Select Case 内の動的な名前付き範囲のアドレス指定

Question

Col H が Col A に依存するドロップダウンボックスであるページを作成しています。

列 A は、データという名前の非表示のシートで指定されている動的名前付き範囲を使用して、検証リストを使用するように既に設定されています。

また、データシートでは、Col A に依存する 3 つのリストを指定し、それらも動的名前付き範囲にしています。

これまでのところ、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

score 1 · Accepted Answer

わかりました。これについてあなたの支援をしてくれた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

excel - Select Case 内の動的な名前付き範囲のアドレス指定

1 に答える 1

Related

Reference