使用VBA进行多标准选择 [英] Multi-Criteria Selection with VBA
问题描述
我创建了一个宏,该宏允许我根据文件名打开多个文件,并将工作表复制到另一个工作簿上.现在,我想添加一些条件,确定数据的最后一行.我用了这个:
I have created a macro that allows me to open multiple files based on their names and copy sheets into one on another workbook. Now I would like to add some criteria, I determine the last row with data. I used this:
lstRow2 = alarms.Cells(alarms.Rows.Count, "A").End(xlUp).Row
现在我想遍历每一行,并检查每一行的列G
是否包含类似("condenser", "pump"
等)的字符串,如果是,则复制该行但不复制整个行,仅复制属于的一系列列该行(例如,与我的条件匹配的每一行,请复制这些列A-B-X-Z
),最后将所有内容复制到另一张纸上.
And now i want to go through each row and check if column G
of each rows contains strings like ("condenser", "pump"
, etc) if yes copy the row but not the whole row, only a series of columns belonging to the row (for example for each row that match my criteria copy those columns A-B-X-Z
) and finally copy all that in another sheet.
感谢您的帮助
推荐答案
具有多条件的灵活过滤器解决方案
这种方法允许多条件搜索定义搜索数组并以高级方式使用Application.Index
函数.此解决方案仅需几个步骤即可避免循环或 ReDim s
:
This approach allows a multi criteria search defining a search array and using the Application.Index
function in an advanced way. This solution allows to avoid loops or ReDim s
nearly completely in only a few steps:
- [0]定义条件数组,例如
criteria = Array("condenser", "pump")
. - [1]将数据A:Z分配给2维数据字段数组:
v = ws.Range("A2:Z" & n)
,其中n是最后一个行号,而ws
是设置的源工作表对象. 注意事项:如果您的基本数据包含任何日期格式,则强烈建议使用.Value2
属性,而不是通过.Value
自动进行默认分配-有关更多详细信息,请参见评论. - [2]搜索列
G
(= 7th col),并通过 helper函数:a = buildAr(v, 7, criteria)
构建一个包含找到的行的数组. li> - [3] 过滤器,使用
Application.Index
函数基于此数组a
并将返回的列值减小为仅A,B,X,Z
. - [4]仅使用一个命令将结果数据字段数组
v
写入目标工作表:ws2.Range("A2").Resize(UBound(v), UBound(v, 2)) = v
,其中ws2是设置的目标工作表对象.
- [0] Define a criteria array, e.g.
criteria = Array("condenser", "pump")
. - [1] Assign data A:Z to a 2-dim datafield array:
v = ws.Range("A2:Z" & n)
, where n is the last row number andws
the set source sheet object. Caveat: If your basic data contain any date formats, it's strictly recommended to use the.Value2
property instead of the automatic default assignment via.Value
- for further details see comment. - [2] Search through column
G
(=7th col) and build an array containing the found rows via a helper function:a = buildAr(v, 7, criteria)
. - [3] Filter based on this array
a
using theApplication.Index
function and reduce the returned column values to onlyA,B,X,Z
. - [4] Write the resulting datafield array
v
to your target sheet using one command only: e.g.ws2.Range("A2").Resize(UBound(v), UBound(v, 2)) = v
, where ws2 is the set target sheet object.
主要过程MultiCriteria
Main procedure 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]
添加到上面的代码中:
If you want to control the results array in the VB Editor's immediate window, you could add the following section '[5]
to the above code:
' [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()
1st helper function 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()
2nd helper 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一样,但是在数组上不起作用,是否有该方法?"
"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?"
通过第二遍搜索项(citeria
),只需更改辅助功能buildAr()
中的逻辑即可通过通配符进行搜索:
Simply change the logic in helper function buildAr()
to search via wild cards by means of a second loop over the search terms (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
编辑II.由于有最后评论-仅检查X列中的现有值
"......我看到了您所做的更改,但我想应用最后一个更简单的想法,(最后一个评论)不使用通配符,而是检查是否有价值在X列中."
只需在辅助函数中挂起逻辑,即可仅通过测量第24列(= X)中修整后的值的长度来检查是否存在现有值,并将主过程中的调用代码更改为
Simply hange the logic in the helper function to check for existing values only by measuring the length of trimmed values in column 24 (=X) and change the calling code in the main procedure to
' [2] build array containing found rows
a = buildAr2(v, 24) ' << check for value in column X = 24
注意:在这种情况下,不需要[0]节来定义标准.
Note: Section [0] defining criteria won't be needed in this case.
辅助功能的版本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
这篇关于使用VBA进行多标准选择的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!