标签：VBA，自定义函数
下面的VBA自定义函数可以实现在单元格区域中查找满足多个值的行或列。代码如下：
代码语言：javascript复制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假设工作表中包含三列，即列A中是水果名，列B中是颜色，列C中是产地，现在查找同时包含“apple”、“red”和“Hungary”的行，可以使用下面的代码：
代码语言：javascript复制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注：本文代码整理自forum.ozgrid.com，供有兴趣的朋友参考。
欢迎在下面留言，完善本文内容，让更多的人学到更完美的知识。
