VBA Copy Entire Row to New Sheet Based on Value in Range

Question

Despite reading several threads searching for answers to similar problems I have been unable to debug my code on its own.

I am trying to write a macro that will search all cells between AE and BF for the term "Aeronautics Engineers" and then copy all rows that contain that term to a new sheet. The entire sheet has a total of 99289.

I have tried using the following code without any luck:

Sub MoveAero()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean

strArray = Array("Aeronautic")

Set wsSource = ActiveSheet

NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add

For I = 1 To NoRows

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I)
    Found = False
    For J = 0 To UBound(strArray)
        Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
    Next J

    If Found Then
        rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)

        DestNoRows = DestNoRows + 1
    End If
Next I
End Sub

Thanks for any assistance!

Answer 1

Your problem is in your j loop:

For J = 0 To UBound(strArray)

The UpperBound ( Ubound ) of array strArray is 0. It's an array with a single element "Aeronautic" .

So your loop is looping once and exiting.

Instead try looping through your range:

For Each rngCell in rngCells.Cells
    if rngCell.value = "Aeronatic" Then 
        Found = True
        Exit For
    End if
Next rngCell

Here we loop through that rngCells range that you just made, cell by cell. Then we test if if the cell has the value you are looking for. If we find it, we set found to true and exit the for loop. You don't have to exit the for loop, but we found what we wanted, so there is no reason not to save some cpu time.

---

Full code, removed unnecessary variables and moved a little bit around:

Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngCell as Range

Set wsSource = ActiveSheet

NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add

For I = 1 To NoRows

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I)

    For Each rngCell in rngCells.Cells
        if rngCell.value = "Aeronatic" Then 
            'Moved this logic up from the IF block below
            rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
            DestNoRows = DestNoRows + 1
            Exit For
        End if
    Next rngCell

Next I
End Sub

Alternatively, you could use that .find method of the range object instead of the second For loop. (Using both for your needs is unnecessary).

Sub MoveAero()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim rngCells As Range

Set wsSource = ActiveSheet

NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add

For I = 1 To NoRows

    Set rngCells = wsSource.Range("AE" & I & ":BF" & I)

    'Try to find your search term in the range
    If Not (rngCells.Find("Aeronautic") Is Nothing) Then
        rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
        DestNoRows = DestNoRows + 1
    End If

Next I
End Sub