Public Function IsRange(vrn As Variant) As Boolean
If IsObject(vrn) Then
If Not vrn Is Nothing Then
IsRange = TypeOf vrn Is Excel.Range
End If
End If
End Function
Public Function Union(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
If rng1 Is Nothing Then
Set Union = rng2
Exit Function
End If
If rng2 Is Nothing Then
Set Union = rng1
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set Union = Application.Union(rng1, rng2)
End Function
Public Function Intersect(ByRef rng1 As Range, _
ByRef rng2 As Range) As Range
If rng1 Is Nothing Or rng2 Is Nothing Then
Exit Function
End If
If Not rng1.Worksheet Is rng2.Worksheet Then
Exit Function
End If
Set Intersect = Application.Intersect(rng1, rng2)
End Function
Public Function MatchAll(ByRef vrnLookupValue As Variant, _
ByRef rngLookupArray As Range) As Range
Dim rngArea As Range
Dim rngTemp1 As Range
Dim rngTemp2 As Range
Dim vrnMatch As Variant
Dim lngCount As Long
Dim lngLast As Long
If rngLookupArray Is Nothing Then
Exit Function
End If
For Each rngArea In rngLookupArray.Areas
If rngArea.Columns.Count > rngArea.Rows.Count Then
Set rngTemp1 = rngArea.Rows
Else
Set rngTemp1 = rngArea.Columns
End If
For Each rngTemp2 In rngTemp1
With rngTemp2
lngCount = .Cells.Count
lngLast = 0
Do
vrnMatch = Application.Match(vrnLookupValue, .Parent.Range(.Cells(lngLast + 1), .Cells(lngCount)), 0)
If IsError(vrnMatch) Then
Exit Do
End If
lngLast = lngLast + vrnMatch
Set MatchAll = Union(MatchAll, .Cells(lngLast))
Loop Until lngLast = lngCount
End With
Next rngTemp2
Next rngArea
End Function
Public Function MatchQuery(ParamArray vrnArgs() As Variant) As Range
Dim rngResult As Range
Dim i As Long
Dim rngLookupArray As Range
Dim rngMatches As Range
If Not IsRange(vrnArgs(0)) Then
Exit Function
End If
Set rngResult = vrnArgs(0)
For i = 1 To UBound(vrnArgs) - 1 Step 2
If Not IsRange(vrnArgs(i)) Then
Exit Function
End If
Set rngLookupArray = vrnArgs(i)
Set rngMatches = MatchAll(vrnArgs(i + 1), Intersect(rngResult.EntireRow, rngLookupArray))
If rngMatches Is Nothing Then
Exit Function
End If
Set rngResult = Application.Intersect(rngResult, rngMatches.EntireRow)
Next i
Set MatchQuery = rngResult
End Function