Multi-Criteria Selection with VBA

Question

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

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.

Thanks for your help

Answer 1

Flexible filter solution with multi-criteria

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] 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 and ws 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 the Application.Index function and reduce the returned column values to only A,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.

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

Possible addition to check the filtered results array

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

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

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

Edit I. due to your comment

"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?"

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

Edit II. due to last comment - check for existing values in column X only

"... 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."

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

Note: Section [0] defining criteria won't be needed in this case.

Version 2 of helper function

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

Answer 2

I would create an SQL statement to read from the various sheets using ADODB, and then use CopyFromRecordset to paste into the destination sheet.

Add a reference (Tools -> References...) to Microsoft ActiveX Data Objects. (Choose the latest version; it's usually 6.1).

The following helper function returns the sheet names as a Collection for a given Excel file path:

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

Then, you can use the following:

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

Something like this maybe:

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