VBA find string in column and move entire row: Do..Loop falling over run time 1004 unable to get FindNext

[Andyatwork]

Hi all,

I've cobbled together the below code from a variety of sources and it is falling over after the first loop.

The ultimate goal is to load an array with a bunch of different search terms, check a given range for the appearance of any one of those terms and if found, cut the affected row and dump it into sheet(2) before looping round until all search terms have been checked.

This code is a proof of concept to get it to work for one search term before trying to bodge an array in there as well.

I get a "run time 1004 unable to get the FindNext property of the Range class" error after the first loop and I can't figure out why.

I'm also not sure of the syntax for fitting shift:=xlup into the code after the found row is cut and dumped into the next worksheet.

Option Explicit
Sub Copy_To_Another_Sheet_1()
    Dim FirstAddress As String
    Dim MyArr() As Variant          'array containing search terms
    Dim Rng As Range                'found cell containing search term
    Dim Rcount As Long, I As Long, lRow As Long
    Dim NewSh As Worksheet      'dumping ground for cut rows
    
'    With Application
'        .ScreenUpdating = False
'        .EnableEvents = False
'    End With
   
'   Fill in the search Value
    MyArr = Array("Deceased")
    Set NewSh = Sheets(2)
'   set last row parameter of data
    With Sheets(1)
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    With Sheets(1).Range("h2:h" & lRow)
        Rcount = 0
        For I = LBound(MyArr) To UBound(MyArr)
            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do
                    Rcount = Rcount + 1
                    Rng.EntireRow.Cut NewSh.Range("A" & Rcount)
                    Set Rng = .FindNext(Rng)
           [COLOR=#ff0000]Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress   ' ERROR HERE
[/COLOR]          End If
        Next I
    End With
'    With Application
'        .ScreenUpdating = True
'        .EnableEvents = True
'    End With
End Sub

Is it something to do with cutting the Rng? I don't really understand the find/findnext terms yet.

Any guidance or solutions would be very welcome.

Regards,

Andy

 

[hiker95]

Andyatwork,

You are looping in an array.

Try adding the BOLD line of code in a test copy of your workbook/worksheet:

        For I = LBound(MyArr) To UBound(MyArr)
          firstaddress = ""

 

[Andyatwork]

Hi, thanks for responding,

I tried that and it now falls over at the Set fndRng = .FindNext(fndRng) line before the Loop.

I've regressed the plan a bit, i'm just trying to get the find...findnext to work, i've dropped the array and am just using a single defined term now but it is still falling over at the .FindNext line and I don't know enough about the logic of it to figure out why. Any pointers?

[FONT=Arial]Option Explicit[/FONT]
[FONT=Arial]Sub Copy_To_Another_Sheet_1()
    Dim FirstAddress As String
  '  Dim nameterms() As Variant              'array containing search terms
    Dim lvrStr As String                    'leaver status deceased
    Dim fndRng As Range                     'found cell containing search term
    Dim Rcount As Long, I As Long, lRow As Long
    Dim dead As Worksheet                   'dumping ground for cut rows
    Dim tables As Worksheet                 'tab containing tables of search terms
    
'    With Application
'        .ScreenUpdating = False
'        .EnableEvents = False
'    End With
    
'   Set search terms and tables
    Set dead = ActiveWorkbook.Sheets("Deceased")
'    Set tables = ActiveWorkbook.Sheets("Tables")
'    nameterms = tables.Range("b2:b3").Value
    lvrStr = "Deceased"
    
'   set last row parameter of data
    With Sheets(1)
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    With Sheets(1).Range("h2:h" & lRow)
        Rcount = 0[/FONT]
[FONT=Arial]           Set fndRng = .Find(What:=lvrStr, _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
            If Not fndRng Is Nothing Then
                FirstAddress = fndRng.Address[/FONT]
[FONT=Arial]               Do
                    Rcount = Rcount + 1
                    fndRng.EntireRow.Cut dead.Range("A" & Rcount)
                    Set fndRng = .FindNext(fndRng)
                Loop While Not fndRng Is Nothing And fndRng.Address <> FirstAddress[/FONT]
[FONT=Arial]           End If[/FONT]
[FONT=Arial]   End With[/FONT]
[FONT=Arial]'    With Application
'        .ScreenUpdating = True
'        .EnableEvents = True
'    End With
End Sub[/FONT]

 

[Andyatwork]

I've worked on it, fixed one problem, found a different problem and bodged a fix for that.

The initial fall over appears to have been caused by limiting the With range to H2:H & lastRow. When i changed that to .Range("H:H") it cycles properly through to the end of the data set.

Then, once it cut the last row it fell over on the last of the Loop While... tests.
I bodged a If fndRng Is Nothing Then Exit Do before the Loop and it now works.

huzzah!

 

[hiker95]

Andyatwork,

Thanks for the feedback.

If you had not found a solution I would have asked to see your workbook/worksheet.

Nicely done.

And, come back anytime.

 

[Andyatwork]

Thank you kindly.

I also eventually figured out that I didn't need the FirstAddress= .fndRng.address as I was cutting the row out of the search range so there was no danger of an infinite loop with the same cell being found over and over.
This also meant that the Loop While line could be cut down to Loop While Not fndRng Is Nothing and I could get rid of my bodge fix.

completed code for reference (if anyone needs it)

[FONT=Verdana]'   Set search terms and tables
    lvrStr = "Deceased"
    Set dead = Worksheets.Add(after:=Worksheets(1)).Name = "Deceased"
    
'   set last row parameter of data
    With opwb.Sheets(1)
        lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    With Sheets(1).Range("j:j")
        Rcount = 0
        Set fndRng = .Find(What:=lvrStr, _
                        after:=.Cells(.Cells.Count), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
            
        If Not fndRng Is Nothing Then
                Do
                    Rcount = Rcount + 1
                    fndRng.EntireRow.Cut dead.Range("A" & Rcount)
                    Set fndRng = .FindNext(fndRng)
                Loop While Not fndRng Is Nothing
        End If[/FONT]
[FONT=Verdana]    End With[/FONT]