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分配给2维数据字段数组：v = ws.Range("A2:Z" & n)，其中n是最后一个行号，而ws是已设置的源工作表对象。 注意事项：如果您的基本数据包含任何日期格式，则强烈建议您使用.Value2属性，而不是通过.Value进行自动默认分配-有关更多详细信息，请参见comment。
[2]搜索列G （= 7th col），并通过 helper函数构建一个包含找到的行的数组：{{1} }。
[3] 过滤器，使用a = buildAr(v, 7, criteria)函数基于此数组a并将返回的列值减小为Application.Index。
[4]仅使用一个命令将结果数据字段数组A,B,X,Z写入目标工作表： v，其中ws2是设置的目标工作表对象。

主要过程ws2.Range("A2").Resize(UBound(v), UBound(v, 2)) = v

MultiCriteria

可能要检查过滤的结果数组

如果要在VB编辑器的即时窗口中控制结果数组，可以将以下部分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添加到上面的代码中：

'[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()

根据您的评论编辑I。

“在GI列中有一个句子（例如，在冷凝器上进行修理），我想当单词“ condenser”出现时，表明它尊重我尝试的标准（“ *冷凝器*”，“ cex“）就像文件名像” book“一样，但不适用于数组，是否有该方法？”

通过第二遍搜索词（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），只需更改辅助功能buildAr()中的逻辑即可通过通配符进行搜索：

citeria

编辑II。由于有最后评论-仅检查X列中的现有值

“ ......我看到了您所做的更改，但我想应用最后一个更简单的想法（最后一个评论），不使用通配符，而是检查是否有价值在X列中。”

仅在辅助函数中添加逻辑以仅通过测量第24列（= X）中的修剪值的长度并将现有程序中的调用代码更改为

来检查是否存在现有值

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

注意：在这种情况下，不需要[0]节来定义标准。

辅助功能的版本2

' [2] build array containing found rows
  a = buildAr2(v, 24)                            ' << check for value in column X = 24

Answer 2

我将创建一个SQL语句以使用ADODB读取各个工作表，然后使用CopyFromRecordset粘贴到目标工作表中。

向 Microsoft ActiveX数据对象添加引用（工具-> 引用... ）。（选择最新版本；通常为6.1）。

以下帮助器函数将工作表名称作为Collection返回给定Excel文件路径：

Function GetSheetNames(ByVal excelPath As String) As Collection
    Dim connectionString As String
    connectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=""" & excelPath & """;" & _
        "Extended Properties=""Excel 12.0;HDR=No"""            

    Dim conn As New ADODB.Connection
    conn.Open connectionString

    Dim schema As ADODB.Recordset
    Set schema = conn.OpenSchema(adSchemaTables)

    Dim sheetName As Variant
    Dim ret As New Collection
    For Each sheetname In schema.GetRows(, , "TABLE_NAME")
        ret.Add sheetName
    Next

    conn.Close
    Set GetSheetNames = ret
End Function

然后，您可以使用以下内容：

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

Answer 3

类似这样的东西：

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

使用VBA进行多标准选择

3 个答案: