vba - 使用 VBA 进行多标准选择

Question

我创建了一个宏，它允许我根据文件名打开多个文件，并将工作表复制到另一个工作簿上。现在我想添加一些标准，我确定最后一行的数据。我用这个:

lstRow2 = alarms.Cells(alarms.Rows.Count, "A").End(xlUp).Row

现在我想遍历每一行并检查列 G每行包含字符串( "condenser", "pump" 等)如果是，则复制行但不复制整行，仅属于该行的一系列列(例如，对于符合我的条件的每一行，复制这些列 A-B-X-Z )最后将所有内容复制到另一张纸上。

谢谢你的帮助

Answer 1

具有多标准的灵活过滤器解决方案

这种方法允许 多条件搜索定义搜索数组并使用 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. 由于您的评论

"In column G I have a sentence for example (repair to do on the condenser) and I would like that as soon as the word "condenser" appears it implies it respects my criteria I tried ("* condenser*", "cex") like if filename like "book" but it doesn't work on an array, is there a method for that?"

只需更改辅助函数中的逻辑 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 列中的现有值

"... I saw the change you did but I wanted to apply the last simpler idea, (last comment ) not using the wild Card but instead to check if there's a value in column 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