Macro cuts and paste whole row below data loop

Question

I have a report that lists the sales for a salesperson for the month. When the type of sale is "Open", the cell in column D will start with O (Open order, open layaway, etc). I can't include the open orders in the subtotal for their monthly sales, but instead have the opens orders in a separate section below their sales in a section called "Open Orders".

So what I need the macro to do is whenever a cell in column D starts with an O, cut whole row and insert (needs to be insert so their isn't blanks when pasting) paste below the data. This will shift the data since we are inserting. The problem that I'm having is that the macro will continue to cut and paste even though we have gone through all the rows in the data set.

Sub MoveOPENS()

'this is what im using to establish the last row in the data set
  Cells(1, 1).Select
  Selection.End(xlDown).Select
  nRowMax = Selection.Row

For i = 2 To nRowMax
    sItem = Cells(i, 4)

    Do While Left(sItem, 1) = "O"
        Rows(i).Select
        Selection.Cut
    'moves the cursor to below the data set
        Selection.End(xlToLeft).Select
        Selection.End(xlDown).Select
        Selection.Offset(4, 0).Select
    'this part works well but it thinks the loop doesn't stop 
    'and will start copy and pasting below the new data section
    Selection.Insert
        sItem = Cells(i, 4)
    Loop
Next i

End Sub

How can i get the macro to know when we have reached the last row so it doesn't continue cutting and paste the rows we just copied and pasted? let me know if you need more details

Here is what the excel sheet looks like

Answer 1

I hope you don't mind that I re-wrote the code from scratch. It looks like you might have recorded a macro to do this, which is a good place to start when you are not sure how to approach it, but it also produces some very inefficient and confusing code sometimes.

Anyway, this should work for you:

Sub MoveOPENS()

Dim LastRow, NewLast, MovedCount As Integer

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row 'Find last Row
NewLast = LastRow + 1 'NewLast tracks the new last row as rows are copied and pasted at the end
MovedCount = 0
    For i = 2 To LastRow
        If Left(Cells(i, 4), 1) = "O" Then    'Copy the row, increment NewLast and paste at the bottom.
            Rows(i).Cut
            'LastRow = LastRow - 1
            Cells(NewLast, 1).Select
            ActiveSheet.Paste
            Rows(i).Delete
            i = i - 1  'Since we deleted the row, we must decrement i
            MovedCount = MovedCount + 1  'Keeps track of number of rows moved so as not to overshoot the original last line

        End If
        If i + MovedCount = LastRow Then Exit For 'Exit For loop if we reached the original last line of the file
    Next i
End Sub

Answer 2

How about:

Sub MoveOPENS()

    Dim lRowMax As Long
    Dim sItem As String


'this is what im using to establish the last row in the data set
    Cells(1, 1).Select
    Selection.End(xlDown).Select
    lRowMax = Selection.Row

    For i = 2 To lRowMax
        sItem = Cells(i, 4).Value

        If Left(sItem, 1) = "O" Then
            Rows(i).Select
            Selection.Cut
            'moves the cursor to below the data set
            Selection.End(xlToLeft).Select
            Selection.End(xlDown).Select
            Selection.Offset(4, 0).Select
            'this part works well but it thinks the loop doesn't stop
            'and will start copy and pasting below the new data section
            Selection.Insert
        End If
    Next i

End Sub

Answer 3

Since you cut rows your nRowMax gets meaningless. Say, you have 1000 rows, but you cut 100 of them, so eventually you'll have 900 rows but you still try to loop through between 901st and 1000nd rows as well.

as a solution, you could create your loop as a do loop instead of for loop, like below.

Sub MoveOPENS()

    Dim sItem As String

    Cells(2, 1).Select
    r = 1
    Do
        sItem = ActiveCell.Offset(0, 3).Value

        If Left(sItem, 1) = "O" Then
            r = ActiveCell.Row
            ActiveCell.EntireRow.Select
            Selection.Cut
            'moves the cursor to below the data set
            Cells(1000000, 1).End(xlUp).Offset(1, 0).Select
            Selection.Insert
            Cells(r, 1).Select
        Else
            ActiveCell.Offset(1, 0).Select
        End If

Loop Until IsEmpty(ActiveCell)

End Sub