Collectives™ on Stack Overflow

Find centralized, trusted content and collaborate around the technologies you use most.

Teams

Q&A for work

Connect and share knowledge within a single location that is structured and easy to search.

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 
                Added an innovative approach to solve your question. BTW as this is your first post have a look at SO and help other developpers to identify a good answer by marking it as accepted  - see "Someone answers".
– T.M.
                Jul 25, 2018 at 19:11
                This solved question has a slightly modified follow up question at Copying values AND color index in an array
– T.M.
                Aug 9, 2018 at 17:17
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, _
      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
     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
     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
     howMany = n
  End If
  ReDim Preserve ar(0 To n - 1)
  buildAr2 = ar
End Function
                First of all I want to thank you for the time you spent writing this code, I tried it and it works, now I'm trying to make some changes. 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?
– Ibrahim
                Jul 26, 2018 at 8:26
                okay I would take your point into account, I had already created a new question but I liked your method and I wanted to deepen it. thank you @T.M.
– Ibrahim
                Jul 31, 2018 at 5:50
                @Ibrahimatto Be aware that your system settings, or default excel settings, may be dictating the order of a date.  Where you may desire yyyymmdd, your computer may be telling it dd/ mm/yyyy.  You can format the column after the fact for a quick fix, or specify the format during the paste..
– Cyril
                Jul 31, 2018 at 19:56
                @Ibrahimatto I would recommend formatting the entire column at the end of your code.  Those formatted correctly will look the same, and those incorrect will be corrected.  As the date is being correctly displayed using the formula in your previous comment, this seems reasonable, as the data is there, just needs to look different.  I am not positive why VBA paste is making that change; there are lots of posts if you google with the same issue, and all seem to make the same suggestion I made... to ensure your settings are correct (excel, system, OS, etc.), otherwise format the data.
– Cyril
                Aug 1, 2018 at 13:19
                @Ibrahimatto .Columns("K").NumberFormat = "dd/mm/yyyy" should do it, provided you fix the column to the correct number... i arbitrarily chose K.
– Cyril
                Aug 1, 2018 at 13:25
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
    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 & ")"
'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
                Basically like your approach as it shows an alternative +1. -  Nevertheless there seem to be some issues: 1) the delimiter in Join function possibly should be "', '" (2) path, sheetName possibly to declare as Variant, outputFilePath is undeclared and unassigned (3) Parameter  excelPath in helper function possibly only Byval excelPath As Variant. Could you test again? (4) In my language version I receive Error No -2147467259 'Tabelle2$' is no valid name calling rs.Open sql, connectionString.
– T.M.
                Jul 26, 2018 at 7:10
                Thanks for your help but I have little knowledge of vba and sql as well as programming so I used the help form T.M which seemed simpler to me because I managed to understand a bit more in addition to his explanations. But I still wanted to thank you for the time and effort you put into trying to help me.
– Ibrahim
                Jul 26, 2018 at 8:29
                @T.M. I've fixed the first three errors (it's kind of you to suggest that I tested this code once; I wrote it of the top of my head without testing at all). RE the fourth issue -- it works by me; could you put the full SQL in a comment here?
– Zev Spitz
                Jul 26, 2018 at 12:56
                Zev: SELECT F1, F2, F24, F26 FROM [Tabelle1$] IN "D:\Daten\Excel\_VBA Bsp\Stack\AllTogether.xlsx" "Excel 12.0;" WHERE F7 IN ('condenser', 'pump') UNION ALL SELECT F1, F2, F24, F26 FROM [Tabelle1$] IN "D:\Daten\Excel\_VBA Bsp\Stack\AllTogether.xlsx" "Excel 12.0;" WHERE F7 IN ('condenser', 'pump') UNION ALL SELECT F1, F2, F24, F26 FROM [Tabelle2$] IN "D:\Daten\Excel\_VBA Bsp\Stack\AllTogether.xlsx" "Excel 12.0;" WHERE F7 IN ('condenser', 'pump') UNION ALL SELECT F1, F2, F24, F26 FROM [Tabelle3$] IN "D:\Daten\Excel\_VBA Bsp\Stack\AllTogether.xlsx" "Excel 12.0;" WHERE F7 IN ('condenser', 'pump')
– T.M.
                Jul 26, 2018 at 19:12
                @T.M. Note that if you want to use your headers instead of autogenerated ones (F1, F2 etc.) you can specify HDR=Yes in the connection string (instead of HDR=No.
– Zev Spitz
                Aug 2, 2018 at 8:06
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
        
Thanks for contributing an answer to Stack Overflow!
Please be sure to answer the question. Provide details and share your research!
But avoid …
Asking for help, clarification, or responding to other answers.
Making statements based on opinion; back them up with references or personal experience.
To learn more, see our tips on writing great answers.