使用VBA实现多个值组合查找

Function findRangeRecursive(findItems As Variant, searchRanges As Variant, RC As Byte, Optional LookIn As Variant, Optional LookAt As Variant, Optional MatchCase As Boolean) As Range
 Dim fii As Long
 Dim baseRange As Range
 Dim resultRange As Range
 Dim rOffset As Long
 Dim cOffset As Long
 
 If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
 If IsMissing(LookAt) Then LookAt = xlWhole ' xlPart
 If IsMissing(MatchCase) Then MatchCase = False
 Set baseRange = searchRanges(LBound(searchRanges))
 For fii = LBound(findItems) To UBound(findItems)
   If fii < UBound(searchRanges) Then
     If RC = 1 Then rOffset = searchRanges(fii + 1).row - baseRange.row
     If RC = 2 Then cOffset = searchRanges(fii + 1).Column - baseRange.Column
   End If
 
   Set resultRange = findRange(findItem:=findItems(fii), searchRange:=baseRange, LookIn:=LookIn, LookAt:=LookAt, MatchCase:=MatchCase)
   If resultRange Is Nothing Then
     Set baseRange = Nothing
     Exit For
   Else
     Set baseRange = IIf(fii < UBound(searchRanges), resultRange.Offset(rOffset, cOffset), Nothing)
   End If
 Next fii
 
 Set findRangeRecursive = resultRange
End Function

Function findRange(findItem As Variant, _
 searchRange As Range, _
 Optional LookIn As Variant, _
 Optional LookAt As Variant, _
 Optional MatchCase As Boolean) As Variant
 
 Dim c As Range
 Dim CustArry() As Variant
 Dim row As Integer
 Dim firstAddress As String
 
 If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
 If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
 If IsMissing(MatchCase) Then MatchCase = False
 
 With searchRange
   Set c = .Find( _
     What:=findItem, _
     LookIn:=LookIn, _
     LookAt:=LookAt, _
     SearchOrder:=xlByRows, _
     SearchDirection:=xlNext, _
     MatchCase:=MatchCase, _
     SearchFormat:=False)
   If Not c Is Nothing Then
     Set findRange = c
     firstAddress = c.Address
     Do
       Set findRange = Union(findRange, c)
       Set c = .FindNext(c)
     Loop While Not c Is Nothing And c.Address <> firstAddress
   End If
 End With
End Function

Sub test()
 Const col1 = 1, col2 = 2, coln = 3
 Const findInCol1 = "apple", findInCol2 = "red", findInColN = "Hungary"
 Dim S As Worksheet, LR As Long
 Dim tmpRange
 Dim rng
 ' 假设有一个至少包含3个字段的工作表
 ' 第1个字段(col1)包含水果名称
 ' 第2个字段(col2)包含颜色
 ' 第3个字段(coln)包含产地名称
 
 ' 现在获取从Hungary出产的Red Apples所在的所有行
 Set S = ActiveSheet
 LR = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
 
 Set tmpRange = findRangeRecursive( _
   findItems:=Array( _
     findInCol1, _
     findInCol2, _
     findInColN _
     ), _
   searchRanges:=Array( _
     S.Range(S.Cells(1, col1), S.Cells(LR, col1)), _
     S.Range(S.Cells(1, col2), S.Cells(LR, col2)), _
     S.Range(S.Cells(1, coln), S.Cells(LR, coln)) _
     ), _
     RC:=2 _
 )
 For Each rng In tmpRange
   Debug.Print rng.Value
 Next rng
End Sub