Excel VBA - 尝试返回仅包含所有条件的值

Question

好的，所以这个很难解释 - 我有一个非常大的桌子，有客户，零件编号，价格和收入。我需要退回所有使用零件编号清单的客户;因此，例如，如果他们使用ABC和DEF部件，那么它将返回使用这些部件的客户，以及这些客户的收入（我想我会将整个行复制到另一个表或其他东西）。

我不希望看到使用一部分但不使用另一部分的客户。我尝试过自动过滤器和高级过滤器而没有运气，但如果可能的话，我宁愿在VBA中这样做。我不确定哪种方式最简单...

一种想法是转动表并按客户排序，但这是非常手动的，我需要将这些结果拉到另一个表中，以便我可以单独看到数据。非常感谢任何帮助！

示例表

Answer 1

在OP澄清之后

编辑。看到添加的代码

您可以使用“Range”对象的“AutoFilter（）”方法的“xlFilterValues”运算符。

假设第一行有标题，这里是您要求的“基本概念”代码：

Dim partListArr As Variant

With Worksheets("MyListSheetName")
     partListArr = Application.Transpose(.Range("A1", .Cells(.Rows.Count,1).End(xlUp)).Value)'<--| retrieve the content of its column A cells from row 1 down to its last not empty cell
End With

With Worksheets("MyDataSheetName")
     With .Range("Z1", .Cells(.Rows.Count,1).End(xlUp)) '<--| reference its A to Z columns cells from row 1 down to column A last not empty cell
         .Autofilter field:=2, Criteria1:=partListArray, operator:=xlFilterValues '<--| filter referenced range on its 2nd field with list of parts
        With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells, skipping headers

            ' here your code to handle filtered cells

        End With
     End With
End With

由于您的澄清，您仍然可以使用嵌套的AutoFilter()来捕获正确的客户共享所有列出的部分，但将此工作留给词典并使用AutoFilter()进行最终复制/粘贴部分会更有效。如下：

Option Explicit

Sub main()
    Dim custDict As Scripting.Dictionary, partDict As Scripting.Dictionary
    Dim cust As Variant, part As Variant
    Dim parts As String
    Dim okCust As Boolean

    With Worksheets("MyListSheetName")
        Set partDict = GetList(.Range("A1", .Cells(.Rows.count, 1).End(xlUp)))
    End With

    With Worksheets("MyDataSheetName")
         With .Range("Z1", .Cells(.Rows.count, 1).End(xlUp)) '<--| reference its A to Z columns cells from row 1 down to column A last not empty cell
            Set custDict = GetList(.Resize(.Rows.count, 1).Offset(1))

            For Each cust In custDict.Keys
                parts = custDict(cust) & "|"
                For Each part In partDict.Keys
                    okCust = InStr(parts, "|" & part & "|") > 0
                    If Not okCust Then Exit For
                Next part
                If okCust Then
                    .AutoFilter field:=1, Criteria1:=cust
                    With .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--| reference filtered cells, skipping headers
                        .Copy Destination:=GetSheet(CStr(cust)).Range("A1")
                    End With
                End If
            Next cust

         End With
        .AutoFilterMode = False
        .Activate
    End With
End Sub

Function GetList(rng As Range) As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    Dim cell As Range

    For Each cell In rng.Cells
        dict(cell.Value) = dict(cell.Value) & "|" & cell.Offset(, 1)
    Next cell

    Set GetList = dict
End Function

Function GetSheet(shtName As String) As Worksheet
    On Error Resume Next
    Set GetSheet = Worksheets(shtName)

    If GetSheet Is Nothing Then
        Set GetSheet = Worksheets.Add
        GetSheet.Name = shtName
    Else
        GetSheet.UsedRange.ClearContents
    End If
End Function