0

I'm trying to copy rows from one worksheet to another based on whether a string exists in a specific cell of each row. In the below example, I'm searching for Jordan in Column J. If that name is in this particular rows Column J, it gets moved to a different sheet (Final Sheet).

Sub Test()
Worksheets("All Data").Activate

Dim N As Long, i As Long
    N = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To N
        If InStr(1, Cells(i, "J"), "Jordan") > 0 Then
            Worksheets("All Data").Rows(i).Copy
            Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next i
End Sub

What I want to do is look for multiple strings. I can accomplish this by adding as many "Or" are needed like below.

If InStr(1, Cells(i, "J"), "Jordan") > 0 Or InStr(1, Cells(i, "J"), "Barkley") > 0 Then

I usually have 5+ strings i'm searching for and it becomes difficult to update the code each time. I would rather the strings I look for be located in a range of cells on some hidden sheet that I or someone can update easily. I've been tinkering with the below. Range does work if its a single cell. If its more such as A1:A5 then it breaks. Any thoughts on how I could accomplish this? Am I totally missing an elegant solution?

Sub Test()
Worksheets("All Data").Activate

Dim N As Long, i As Long
    N = Cells(Rows.Count, 1).End(xlUp).Row

    For i = 2 To N
        If InStr(1, Cells(i, "J"), Worksheets("List").Range("A1:A5")) > 0 Then
            Worksheets("All Data").Rows(i).Copy
            Worksheets("Final Sheet").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next i
End Sub

List Sheet
- |    A    |
1 | Jordan  |
2 | Barkley |
3 | Batman  |
4 | Robin   |
5 | Ozzy    |
  • 1
    Do these cells contain other text too, e.g. "foo Jordan bar" or just "Jordan"? If the former, perhaps [this](https://stackoverflow.com/questions/51206261/autofilter-with-multiple-criteria-using-an-array-of-ranges) could help. – BigBen Jan 09 '20 at 21:55
  • Quick first remark: `Cells(Rows.Count, 1).End(xlUp).Row` would work on the currently `ActiveSheet`. Since you cope rows from `Worksheets("All Data")`, I suppose the potential last row, is not nessecarily what you are after. – JvdV Jan 09 '20 at 21:57
  • 1
    And even so @BigBen, you are allowed `*` wildcards =). `AutoFilter` is a good recommendation indeed. It would become a need to know when you pass an array of values to search for (which won't allow the use of wildcards) – JvdV Jan 09 '20 at 21:58
  • @JvdV - I knew wildcards were allowed, just wasn't sure if you could incorporate them in this case, but yeah that's how I'd go. – BigBen Jan 09 '20 at 22:00
  • @BigBen These cells do contain other text! Sometimes a whole paragraph. I was trying to keep the example simple with just names in the above :) – TeaSniffer Jan 09 '20 at 22:27
  • @JvdV I just added Worksheets("All Data").Activate slipped my mind when writing the example code – TeaSniffer Jan 09 '20 at 22:30

1 Answers1

0

Based on this previous answer, I customize it to your scenario

Remember to backup your data before running it.

Read the code's comments and adjust the variables' values to fit your needs.

Public Sub CopyData()

    ' Define the object variables
    Dim sourceWorksheet As Worksheet
    Dim targetWorksheet As Worksheet

    Dim listRange As Range
    Dim evalCell As Range

    ' Define other variables
    Dim listRangeAddress As String

    Dim startSourceRow As Long
    Dim lastSourceRow As Long
    Dim columnForLastRowSource As Long

    Dim lastTargetRow As Long
    Dim sourceRowCounter As Long
    Dim columnForLastRowTarget As Long

    Dim columnToEval As Long


    ''''' Adjust the folloing values ''''

    ' Set the lookup list range address
    listRangeAddress = "B1:B5"

    ' Adjust the worksheets names
    Set sourceWorksheet = ThisWorkbook.Worksheets("All Data")
    Set targetWorksheet = ThisWorkbook.Worksheets("Final Sheet")
    Set listRange = ThisWorkbook.Worksheets("List").Range(listRangeAddress)

    ' Set the initial row where data is going to be evaluated
    startSourceRow = 1

    ' Set the column from which you're going to get the last row in sourceSheet
    columnForLastRowSource = 1

    ' Set the column from which you're going to get the last row in targetSheet
    columnForLastRowTarget = 1

    ' Set the column where you evaluate if condition is met
    columnToEval = 10



    '''''''Loop to copy rows that match'''''''

    ' Find the number of the last row in source sheet
    lastSourceRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, columnForLastRowSource).End(xlUp).Row

    For sourceRowCounter = startSourceRow To lastSourceRow

        For Each evalCell In listRange.Cells

            ' Evaluate if criteria is met in column
            If InStr(sourceWorksheet.Cells(sourceRowCounter, columnToEval).Value, evalCell.Value) > 0 Then

                ' Get last row on target sheet (notice that this search in column A = 1)
                lastTargetRow = targetWorksheet.Cells(targetWorksheet.Rows.Count, columnForLastRowTarget).End(xlUp).Row

                ' Copy row to target
                sourceWorksheet.Rows(sourceRowCounter).Copy targetWorksheet.Rows(lastTargetRow + 1)

                ' If found, don't keep looking
                Exit For

            End If

        Next evalCell

    Next sourceRowCounter

End Sub

Let me know if it works and remember to mark the answer if it does.

Ricardo Diaz
  • 5,658
  • 2
  • 19
  • 30
  • Wow, this worked like a charm. I've honestly been reading and rereading this bit of code all morning to better understand how this is working (which it does). It also runs alot faster than what I put together. I run this on a data set of about 5000+ rows. With my code it would make excel flip out for about 2 minutes but yours just has a mouse loading symbol and completes faster as well I think. It also didn't miss any of the data on the first pass like mine usually would. Definetly going to keep studying this and use it as a benchmark to make more of my work easier.! – TeaSniffer Jan 10 '20 at 17:42