基于VBA的多准则选择_Vba_Excel

基于VBA的多准则选择

vba excel

基于VBA的多准则选择,vba,excel,Vba,Excel,我创建了一个宏，允许我根据文件名打开多个文件，并将工作表复制到另一个工作簿中。现在我想添加一些标准，我用数据确定最后一行。我用了这个： lstRow2 = alarms.Cells(alarms.Rows.Count, "A").End(xlUp).Row 现在我想检查每一行，检查每一行的列G是否包含类似（“concerter”，“pump”，等等）的字符串。如果是，则复制该行，但不复制整行，只复制属于该行的一系列列（例如，对于符合我的条件的每一行，复制这些列a-B-X-Z）最后把这些都复制到

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

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

现在我想检查每一行，检查每一行的列

是否包含类似（

“concerter”，“pump”

，等等）的字符串。如果是，则复制该行，但不复制整行，只复制属于该行的一系列列（例如，对于符合我的条件的每一行，复制这些列

a-B-X-Z

）最后把这些都复制到另一张纸上

谢谢你的帮助

像这样的事情也许：

j = 0
For i = To alarms.Rows.Count
   sheetname = "your sheet name"
   If (Sheets(sheetname).Cells(i, 7) = "condenser" Or Sheets(sheetname).Cells(i, 7) = "pump") Then
       j = j + 1
       Sheets(sheetname).Cells(i, 1).Copy Sheets("aff").Cells(j, 1) 
       Sheets(sheetname).Cells(i, 2).Copy Sheets("aff").Cells(j, 2) 
   End If
Next i

可能是这样的：

j = 0
For i = To alarms.Rows.Count
   sheetname = "your sheet name"
   If (Sheets(sheetname).Cells(i, 7) = "condenser" Or Sheets(sheetname).Cells(i, 7) = "pump") Then
       j = j + 1
       Sheets(sheetname).Cells(i, 1).Copy Sheets("aff").Cells(j, 1) 
       Sheets(sheetname).Cells(i, 2).Copy Sheets("aff").Cells(j, 2) 
   End If
Next i

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

这种方法允许多标准搜索定义搜索数组，并以高级方式使用

应用程序.Index

功能。此解决方案允许通过几个步骤几乎完全避免循环或

：

[0]定义标准数组，例如标准=数组（“冷凝器”、“泵”）
[1] 将数据A:Z分配给二维数据字段数组：v=ws.Range（“A2:Z”&n）
，其中n是最后一行编号，而ws是设置的源表对象。
警告：如果您的基本数据包含任何日期格式，则严格建议使用.Value2
属性，而不是通过.Value
自动默认赋值-有关详细信息，请参阅
[2] 搜索列G
（=7th col），并通过辅助函数构建包含找到的行的数组：a=buildAr（v，7，criteria）
[3] 使用应用程序基于此数组a
筛选索引函数，并将返回的列值减少为仅a、B、X、Z

[4] 仅使用一个命令将结果数据字段数组v
写入目标工作表：例如ws2.Range（“A2”）.Resize（UBound（v），UBound（v，2））=v
，其中ws2是设置的目标工作表对象

主程序多标准
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

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

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

1st helper函数buildAr（）
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

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

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.
“在G列中，我有一个句子，例如（电容器上的修复），我希望在“电容器”一词出现时，它意味着它符合我尝试的标准（“*concerter*”，“cex”），比如如果文件名类似于“book”，但在数组上不起作用，有什么方法吗？”
只需更改helper函数buildAr（）
中的逻辑，通过搜索词（citeria
）上的第二个循环，通过通配符进行搜索即可：
函数buildAr（v，ByVal vColumn&，criteria）作为变量
'用途：辅助功能，用于检查标准阵列（例如“冷凝器”、“泵”）
'注：由[2]节中的主函数MultiCriteria调用
Dim found&，found2&，i&，j&，n&，ar:ReDim ar（0到UBound（v）-1）
“多少=0”将布尔值重置为默认值
对于i=LBound（v）到UBound（v）
找到=0
错误时继续下一步“避免未找到错误”
''**原始命令已注释掉**
'found=Application.Match（v（i，vColumn），条件，0）
对于j=LBound（标准）到UBound（标准）
found=Application.Match（“*”&criteria（j）和“*”，Split（v（i，vColumn）和“”），0）
如果发现>0，则ar（n）=i:n=n+1：退出
下一个j
接下来我
如果n<2，则
多少人=n:n=2
其他的
多少=n
如果结束
重拨保留ar（0到n-1）
buildAr=ar
端函数

编辑II。由于最后一条评论-仅检查第X列中的现有值
“…我看到了您所做的更改，但我想应用最后一个更简单的想法，（最后一条评论）不使用通配符，而是检查X列中是否有值。”
只需更改helper函数中的逻辑，仅通过测量第24列（=X）中修剪值的长度来检查现有值，并将主过程中的调用代码更改为
' [2] build array containing found rows
  a = buildAr2(v, 24)                            ' << check for value in column X = 24

”[2]生成包含找到的行的数组
a=buildAr2（v，24）'0然后
ar（n）=i
n=n+1
如果结束
接下来我
如果n<2，则
多少人=n:n=2
其他的
多少=n
如果结束
重拨保留ar（0到n-1）
buildAr2=ar
端函数
灵活的多标准过滤解决方案
这种方法允许多标准搜索定义搜索数组，并以高级方式使用应用程序.Index
功能。此解决方案允许通过几个步骤几乎完全避免循环或：

[0]定义标准数组，例如标准=数组（“冷凝器”、“泵”）
[1] 将数据A:Z分配给二维数据字段数组：v=ws.Range（“A2:Z”&n）
，其中n是最后一行编号，而ws是设置的源表对象。
警告：如果您的基本数据包含任何日期格式，则严格建议使用.Value2
属性，而不是通过.Value
自动默认赋值-有关详细信息，请参阅
[2] 搜索列G
（=7th col），并通过辅助函数构建包含找到的行的数组：a=buildAr（v，7，criteria）
[3] 使用应用程序基于此数组a
筛选索引函数，并将返回的列值减少为仅a、B、X、Z

[4] 仅使用一个命令将结果数据字段数组v
写入目标工作表：例如ws2.Range（“A2”）。Resize（UBound（v）、UBound（v、，
Dim paths As Variant
paths = Array("c:\path\to\first.xlsx", "c:\path\to\second.xlsx")

Dim terms As String
terms = "'" & Join(Array("condenser", "pump"), "', '") & "'"

Dim path As Variant
Dim sheetName As Variant
Dim sql As String
For Each path In paths
    For Each sheetName In GetSheetNames(path)
        If Len(sql) > 0 Then sql = sql & " UNION ALL "
        sql = sql & _
            "SELECT F1, F2, F24, F26 " & _
            "FROM [" & sheetName & "] " & _
                "IN """ & path & """ ""Excel 12.0;"" " & _
            "WHERE F7 IN (" & terms & ")"
    Next
Next

'We're connecting here to the current Excel file, but it doesn't really matter to which file we are connecting
Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & ActiveWorkbook.FullName & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No"""     

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Worksheets("Destination").Range("A1").CopyFromRecordset rs