灵活的多条件过滤解决方案
这种方法允许多条件搜索定义搜索数组并以高级方式使用Application.Index 函数。此解决方案只需几个步骤即可几乎完全避免循环或ReDim s：
- [0] 定义条件数组，例如
criteria = Array("condenser", "pump")。
- [1] 将数据 A:Z 分配给二维数据字段数组：
v = ws.Range("A2:Z" & n)，其中 n 是最后一行编号，ws 是设置的源工作表对象。
警告：如果您的基本数据包含任何日期格式，强烈建议使用.Value2 属性，而不是通过.Value 自动默认分配 - 有关详细信息，请参阅comment。
- [2] 搜索列
G(=7th col) 并通过 帮助函数 构建包含找到的行的数组：a = buildAr(v, 7, criteria)。李>
- [3] 过滤基于此数组
a 使用Application.Index 函数并将返回的列值减少到仅A,B,X,Z。
- [4] 仅使用一个命令将生成的数据字段数组
v 写入目标工作表：例如ws2.Range("A2").Resize(UBound(v), UBound(v, 2)) = v，其中 ws2 为设置的目标工作表对象。
主程序MultiCriteria
Option Explicit ' declaration head of code module
Dim howMany& ' findings used in both procedures
Sub MultiCriteria()
' Purpose: copy defined columns of filtered rows
Dim i&, j&, n& ' row or column counters
Dim a, v, criteria, temp ' all together variant
Dim ws As Worksheet, ws2 As Worksheet ' declare and set fully qualified references
Set ws = ThisWorkbook.Worksheets("Sheet1") ' <<~~ change to your SOURCE sheet name
Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' <<~~ assign to your TARGET sheet name
' [0] define criteria
criteria = Array("condenser", "pump") ' <<~~ user defined criteria
' [1] Get data from A1:Z{n}
n = ws.Range("A" & Rows.Count).End(xlUp).Row ' find last row number n
v = ws.Range("A2:Z" & n) ' get data cols A:Z and omit header row
' [2] build array containing found rows
a = buildAr(v, 7, criteria) ' search in column G = 7
' [3a] Row Filter based on criteria
v = Application.Transpose(Application.Index(v, _
a, _
Application.Evaluate("row(1:" & 26 & ")"))) ' all columns
' [3b] Column Filter A,B,X,Z
v = Application.Transpose(Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(a) - LBound(a) + 1 & ")"), _
Array(1, 2, 24, 26)))) ' only cols A,B,X,Z
' [3c] correct rows IF only one result row found or no one
If howMany <= 1 Then v = correct(v)
' [4] Copy results array to target sheet, e.g. starting at A2
ws2.Range("A2").offset(0, 0).Resize(UBound(v), UBound(v, 2)) = v
End Sub
检查过滤结果数组的可能添加
如果您想在 VB 编辑器的即时窗口中控制结果数组，您可以在上面的代码中添加以下部分 '[5]：
' [5] [Show results in VB Editor's immediate window]
Debug.Print "2-dim Array Boundaries (r,c): " & _
LBound(v, 1) & " To " & UBound(v, 1) & ", " & _
LBound(v, 2) & " To " & UBound(v, 2)
For i = 1 To UBound(v)
Debug.Print i, Join(Application.Index(v, i, 0), " | ")
Next i
第一个辅助函数buildAr()
Function buildAr(v, ByVal vColumn&, criteria) As Variant
' Purpose: Helper function to check criteria array (e.g. "condenser","pump")
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
found = 0
On Error Resume Next ' avoid not found error
found = Application.Match(v(i, vColumn), criteria, 0)
If found > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr = ar
End Function
第二个辅助函数correct()
Function correct(v) As Variant
' Purpose: reduce array to one row without changing Dimension
' Note: called by main function MultiCriteria in section [3c]
Dim j&, temp: If howMany > 1 Then Exit Function
ReDim temp(1 To 1, LBound(v, 2) To UBound(v, 2))
If howMany = 1 Then
For j = 1 To UBound(v, 2): temp(1, j) = v(1, j): Next j
ElseIf howMany = 0 Then
temp(1, 1) = "N/A# - No results found!"
End If
correct = temp
End Function
编辑 I. 由于您的评论
“在 GI 栏中有一个句子，例如（修理冷凝器），我希望一旦出现“冷凝器”这个词就意味着它尊重我尝试过的标准（“*冷凝器*”，“ cex") 就像文件名像 "book" 但它不适用于数组，有没有办法？"
只需将帮助函数buildAr() 中的逻辑更改为通过通配符 进行搜索，方法是对搜索词进行第二次循环 (citeria)：
Function buildAr(v, ByVal vColumn&, criteria) As Variant
' Purpose: Helper function to check criteria array (e.g. "condenser","pump")
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, j&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
found = 0
On Error Resume Next ' avoid not found error
' ' ** original command commented out**
' found = Application.Match(v(i, vColumn), criteria, 0)
For j = LBound(criteria) To UBound(criteria)
found = Application.Match("*" & criteria(j) & "*", Split(v(i, vColumn) & " ", " "), 0)
If found > 0 Then ar(n) = i: n = n + 1: Exit For
Next j
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr = ar
End Function
编辑二。由于最后的评论 - 仅检查 X 列中的现有值
"...我看到了您所做的更改，但我想应用最后一个更简单的想法，（最后一条评论）不使用通配符，而是检查是否有值在 X 列中。”
只需将辅助函数中的逻辑挂起，仅通过测量第 24 列中修剪值的长度 (=X) 来检查现有值，并将主过程中的调用代码更改为
' [2] build array containing found rows
a = buildAr2(v, 24) ' << check for value in column X = 24
注意：在这种情况下，不需要第 [0] 节定义标准。
辅助函数的第 2 版
Function buildAr2(v, ByVal vColumn&, Optional criteria) As Variant
' Purpose: Helper function to check for existing value e.g. in column 24 (=X)
' Note: called by main function MultiCriteria in section [2]
Dim found&, found2&, i&, n&, ar: ReDim ar(0 To UBound(v) - 1)
howMany = 0 ' reset boolean value to default
For i = LBound(v) To UBound(v)
If Len(Trim(v(i, vColumn))) > 0 Then
ar(n) = i
n = n + 1
End If
Next i
If n < 2 Then
howMany = n: n = 2
Else
howMany = n
End If
ReDim Preserve ar(0 To n - 1)
buildAr2 = ar
End Function