For Each Cell... Next Cell Loop Only Works Once
<p>My code finds cells in a predefined range "r" that have a value of "Completed", but using the For Each Cell and Next Cell commands does not loop the code to find more than one "Completed" cell.</p>

<p>What am I missing? Any help would be appreciated.</p>

<pre><code>Sub Move_Burn()

Dim Msg As String, Ans As Variant

  Msg = "Are you sure you want to move the completed pumps?"

  Ans = MsgBox(Msg, vbYesNo)

  Select Case Ans

Case vbYes

Dim r As Range, cell As Range, mynumber As Long, r2 As Range

Set r = Range("AR15:AR1000")
Set r2 = Range("AF15:AF1000")

mynumber = 1
For Each cell In r
    If cell.Value = "Completed" Then
    Range("AT15:BN15").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("AT15:BN15").Interior.ColorIndex = xlNone

    End If

    If cell.Value = "Completed" Then
    cell.Select
    cell.Value = "Delete"
    Range(ActiveCell, ActiveCell.Offset(0, -20)).Select
    Selection.Copy
    Range("AT15").Select
    ActiveSheet.Paste

    Range("BN15").ClearContents

    End If

    If cell.Value = "Delete" Then
    cell.Select
    Range(ActiveCell, ActiveCell.Offset(0, -20)).Select
    Selection.Delete Shift:=xlUp

    End If

    Next cell

Case vbNo
  GoTo Quit:
    End Select
Quit:

  End Sub
</code></pre>