如何在 VBA 中设置依赖于相邻单元格值的下拉列表？

Question

在第一张纸上，我有一个名为“Inventory”的表格，它有两列。第一列包含所有条形码，第二列包含项目的描述。

例子：

Barcode	Description
1111	Item 1
2222	Item 2
3333	Item 3
4444	Item 4
2222	Item 222

在第二张表上，我有一个名为“Out”的表格，您可以在第一列的单元格中输入条形码，第二列中的相邻单元格根据在公式查找。

此时，我没有遇到任何问题，一切正常。

但有些条形码有多个不同的描述（如条形码“2222”的示例所示），我希望能够使用仅显示不同项目的下拉列表更改项目的描述具有相同的条形码。

例如，如果我输入条形码“2222”，则相邻单元格将显示“项目 2”。我想在描述单元格上安装一个下拉列表，其中将显示项目 2 和项目 222，然后选择我想要的。

你能帮我解决这个问题吗？

    Sub Data_Val()

    dim Inventory_Sheet, Out_Sheet as Worksheet

    set Inventory_sheet = Thisworkbook.worksheets("Inventory")
    set Out_Sheet = thisworkbook.worksheets("Out")

    Out_Sheet.activate

    Range("B2").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, _
         AlertStyle:=xlValidAlertStop, _
         Operator:=xlBetween, _
         Formula1:="='Inventory'!$B$2:$B$6"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
    End Sub 

Answer 1

请使用下一个方法：

1. 以下代码需要引用“Microsoft Scripting Runtime”。它可以在没有它的情况下使用后期绑定来处理，但您不会从智能感知建议中受益。使用下面的代码自动创建它：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub

运行代码并保存工作簿！

1. 在标准模块中创建Public变量：

Public dictDescript As Scripting.Dictionary

1. 复制“库存”表中的下一个代码代码模块：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, arrT, i As Long
   Set rng = Me.ListObjects("Inventory").DataBodyRange
   If Not Intersect(Target, rng) Is Nothing Then
        Set dictDescript = New Scripting.Dictionary
        arrT = rng.value                      'to make code faster
        For i = 1 To UBound(arrT)
            'update the dictionary
            If Not dictDescript.Exists(arrT(i, 1)) Then
                dictDescript.Add arrT(i, 1), arrT(i, 2)
            Else
                dictDescript(arrT(i, 1)) = dictDescript(arrT(i, 1)) & "|" & arrT(i, 2)
            End If
        Next i
   End If
End Sub

当表格中的某些内容被修改时，它将更新必要的字典。

4. 复制工作表中的下一个代码，保留“Out”表代码模块：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rngO As Range
   Set rngO = Me.ListObjects("Out").DataBodyRange.Columns(1)
   
   If Not Intersect(Target, rngO) Is Nothing Then
       If dictDescript Is Nothing Then 'if nothing has been placed in the dictionary:
            Dim rng As Range, arrT, i As Long, strCondition As String
            Set rng = Worksheets("Inventory").ListObjects("Inventory").DataBodyRange
            Set dictDescript = New Scripting.Dictionary
             arrT = rng.value                      'to make code faster
             For i = 1 To UBound(arrT)
                 'update the dictionary
                 If Not dictDescript.Exists(arrT(i, 1)) Then
                     dictDescript.Add arrT(i, 1), arrT(i, 2)
                 Else
                     dictDescript(arrT(i, 1)) = dictDescript(arrT(i, 1)) & "," & arrT(i, 2)
                 End If
             Next i
        End If
       'return the validation list from the dictionary:
        strCondition = dictDescript(Target.value)
        If strCondition = "" Then  'if a wrong string has been inputed (not one of the barcodes in Inventory sheet)
            MsgBox Target.value & " barcode, does not exist in ""Inventory"" sheet...", vbInformation, _
                                                                                         "No appropriate barcode input"
            Target.Offset(0, 1).Validation.Delete: Target.Offset(0, 1).value = ""
            Exit Sub
        End If
        'create the validation:
        Target.Offset(0, 1).value = ""
        With Target.Offset(0, 1).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=strCondition
            .IgnoreBlank = True
            .InCellDropdown = True
            .ShowInput = True
            .ShowError = True
        End With
    End If
End Sub

使用您的条形码并发送一些反馈。