For Each Command Does Not Loop

Question

My code below is used to find cells with "Completed" value and to select a set range in that row and move it to another range.

I used the For Each command hoping that it would find every range with "Completed" and move them all once I click the macro but it only moves one at a time, is it possible to move all one after another without clicking the macro multiple times?

Any help would be appreciated, thanks in advance.

Sub Move_Characterisation()

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("V15:S1000")

mynumber = 1
 For Each cell In r
   If cell.Value = "Completed" Then
    Range("X15:AR15").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("X15:AR15").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("X15").Select
    ActiveSheet.Paste

   Range("AR15").ClearContents

   End If

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

   End If

   Next

Case vbNo
  GoTo Quit:
    End Select

Quit:

  End Sub