excel - VBA Excel - 带有 2 个关键字段的下拉列表

Question

我一直在为这个要求苦苦挣扎。

我有 2 个 Excel 工作表，如下所示：Sheet1

表2：

要求是根据 MA​​T 字段中的键值和 Sheet1 中的植物字段在下拉列表中获取批次列表。

我已经使用附加列“KEY”完成了它，其中我对“MAT”和“Plant”两个字段的值使用合并，并使用带有 INDIRECT 的数据验证

但我想在没有额外列且不合并键值的情况下执行此操作。

标签： excelvba

Answer 1

试试下面的。

Private Sub LoadData()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lLastRowSheet1 As Long, lLastRowSheet2 As Long, i As Long
    Dim TheCombination As String
    Dim TheBatch As String
    Dim TheOptions() As String

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Set ws2 = ThisWorkbook.Sheets("Sheet2")
    lLastRowSheet1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    lLastRowSheet2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

    'Add elements to dictionary
    For i = 2 To lLastRowSheet1
        TheCombination = ws1.Cells(i, 1).Value & ws1.Cells(i, 2).Value 'combine MAT and PLANT
        TheBatch = ws1.Cells(i, 3).Value

        If Not dict.Exists(TheCombination) Then 'If key does not exist, add it
            dict.Add TheCombination, TheBatch
        Else
            TheItems = Split(dict.Item(TheCombination), ",")
            If Not IsInArray(TheBatch, TheItems) Then
                dict.Item(TheCombination) = dict.Item(TheCombination) & "," & ws1.Cells(i, 3).Value 'Add Batch if not already added
            End If
        End If
    Next

    For i = 2 To lLastRowSheet2
        TheSheet2Combination = ws2.Cells(i, 1).Value & ws2.Cells(i, 2).Value
        TheOptions = Split(dict.Item(TheSheet2Combination), ",")
        With ws2.Cells(i, 3).Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlEqual, Formula1:=Join(TheOptions, ",")
        End With
    Next
End Sub


Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function