How to find multiple strings from Excel and copy into another spreadsheet using VBA

Question

Example

I have spreadsheet(Sheet2) like

Spreadsheet

I need to search "Tran1" and "app" full row data from my excel-sheet and after searching the record I need to copy the rows into Sheet3.

Currently I am able to do it only for 1 record "Tran1" but i need to do it with multiple values.

Here is my code snippet:

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute
   LSearchRow = 4
   LCopyToRow = 2

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0
        If InStr(1, Range("A" & CStr(LSearchRow)).Value, "tran1") > 0 Then

         'Select row in Sheet2 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet3 in next row
         Sheet3.Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet2 to continue searching
         Sheet2.Select

      End If
      LSearchRow = LSearchRow + 1
   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub
Err_Execute:
   MsgBox "An error occurred."

Can anyone let me tell how to do with multiple search.?

I would rather use VBA Autofilter feature to filter my records, copy visible rows and paste them in other sheet. That will be more faster and will do the job with less lines of code. — J.B., Jan 18 '17 at 10:17

score 0 · Answer 1 · edited May 23 '17 at 11:45

Here is a possible solution for your request:

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
    dim lCounter        as long 
   On Error GoTo Err_Execute
   LSearchRow = 4
   LCopyToRow = 2

    dim varValues(3)        as variant
    varValues(0) = "tran1"
    varValues(1) = "tran2"
    varValues(2) = "tran3"

   for lCounter = lbound(varValues) to ubound(varValues)

       While Len(Range("A" & CStr(LSearchRow)).Value) > 0
            If InStr(1, Range("A" & CStr(LSearchRow)).Value, varValues(0)) > 0 Then

             'Select row in Sheet2 to copy
             Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
             Selection.Copy

             'Paste row into Sheet3 in next row
             Sheet3.Select
             Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
             ActiveSheet.Paste

             'Move counter to next row
             LCopyToRow = LCopyToRow + 1

             'Go back to Sheet2 to continue searching
             Sheet2.Select

          End If
          LSearchRow = LSearchRow + 1
       Wend
   next

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub
Err_Execute:
   MsgBox "An error occurred."

lCounter and varValues are further declared. varValues gets 2 more values, tran1, tran2 and tran3. Thus, I have created a for loop, that loops all over them. The logic in the While loop is left.

In general, your code uses Select, which is a bad practise in VBA, but as far as it works it is ok. Here is how to avoid the selection - How to avoid using Select in Excel VBA macros

score 0 · Answer 2 · answered Jan 18 '17 at 10:07

A simple use of And in you If statement will do the trick!

(I've tested the column B for "app", I'll let you tune it to the right column ;) )

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer

    On Error GoTo Err_Execute
    LSearchRow = 4
    LCopyToRow = 2

    While Len(Range("A" & CStr(LSearchRow)).Value) > 0
         If InStr(1, Sheet2.Range("A" & CStr(LSearchRow)).Value, "tran1") > 0 And _
             InStr(1, Sheet2.Range("B" & CStr(LSearchRow)).Value, "app") > 0 Then

          'Select row in Sheet2 to copy
          Sheet2.Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Copy

          'Paste row into Sheet3 in next row
          Sheet3.Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Paste

          'Move counter to next row
          LCopyToRow = LCopyToRow + 1
       End If
       LSearchRow = LSearchRow + 1
    Wend

    'Position on cell A3
    Application.CutCopyMode = False
    Sheet2.Range("A3").Select

    MsgBox "All matching data has been copied."

    Exit Sub
Err_Execute:
    MsgBox "An error occurred."

score 0 · Answer 3 · answered Jan 18 '17 at 11:07

AutoFilter() gets things quite easy and short:

Sub Main()
    With Sheets("Sheet2") '<--| reference "data" sheet
        With .Range("C1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its columns A:C range from row 1 (headers) down to column A last not empty row
            .AutoFilter field:=1, Criteria1:=Array("tran1", "app"), Operator:=xlFilterValues '<--| filter referenced range on its 1st column (i.e. "Name") with "tran" and "app"
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet3").Cells(2, 1) '<--| if any filterd cells other than header then copy them and paste to Sheets("Sheet3") from its row 2
        End With
        .AutoFilterMode = False
    End With
End Sub

How to find multiple strings from Excel and copy into another spreadsheet using VBA

3 Answers3