vba - For Each loop: How to adjust code to move files in one run rather than multiple

Question

I am using the below code to archive emails that have been marked completed. It is supposed to check all emails in our shared folder for anything marked complete prior to today's date. It works, but I must run the code multiple times to archive all of the affected quoted. Does anyone have any ideas how to get this to work in one shot?

Public Const CEpath As String = "\s-estimatingCentralEstimating"

Option Explicit
Public Const sArchivePath As String = Miscellaneous.CEpath + "Archives"

Public Sub ArchiveInbox()
  Dim dtDateToMove As Date
  Dim iMessageCount As Integer
  Dim oDestination As MAPIFolder
  Dim oFileName As String
  Dim oNamespace As NameSpace
  Dim oMailItem As MailItem
  Dim oProgress As New ProgressDialogue
  Dim oSource As MAPIFolder
  Dim oStore As Store
  Dim oOSPsource As MAPIFolder
  'Dim oOSPDestination As MAPIFolder

  On Error GoTo HandleError

  ' Obtain a NameSpace object reference.
  Set oNamespace = Application.GetNamespace("MAPI")
  Set oStore = oNamespace.Stores.item("Rings")
  Set oSource = oStore.GetDefaultFolder(olFolderInbox)

  ' try to connect to the OSP Folder
  On Error Resume Next
  'Debug.Print oSource.Folders("OSP Quotes").Items.count
  Set oOSPsource = oSource.Folders("OSP Quotes")
  On Error GoTo HandleError

  ' Start Progess form
  oProgress.Configure title:="Archive Old RFQs", _
                      status:="Please stand by while the operation is being processed…", _
                      Min:=0, _
                      Max:=CDbl(oSource.Items.count), _
                      optShowTimeElapsed:=True, _
                      optShowTimeRemaining:=True
  oProgress.Show vbModeless

  ' Open Archive (or create and open)
  dtDateToMove = PreviousBusinessDay(Date)
  If Month(PreviousBusinessDay(Date)) < 7 Then
    oFileName = "RFQs " & Year(dtDateToMove) & " - Jan-Jun"
  Else
    oFileName = "RFQs " & Year(dtDateToMove) & " - Jul-Dec"
  End If
'  Debug.Print dtDateToMove
'  Debug.Print oFileName
  oNamespace.AddStoreEx Store:=sArchivePath & oFileName & ".pst", _
                        Type:=olStoreUnicode
  Set oDestination = oNamespace.Folders.GetLast
  If Not oDestination.Name = oFileName Then oDestination.Name = oFileName

  ' Sort through all closed emails in Rings and move them to the archive folder
  For Each oMailItem In oSource.Items
    iMessageCount = iMessageCount + 1
    If oProgress.cancelIsPressed Then Exit For
'    Debug.Print "   " & oMailItem.TaskCompletedDate

    If oMailItem.FlagStatus = olFlagComplete Then
      If oMailItem.IsConflict Then
        Err.Raise Number:=95, _
                  Description:="Mail Item Conflict Detected"
      End If
      If oMailItem.TaskCompletedDate <= dtDateToMove Then
        oMailItem.Move oDestination
'        Debug.Print "      Moved"
      End If
    End If
    oProgress.SetValue iMessageCount
  Next oMailItem

ExitRoutine:
  oProgress.Hide

  If oOSPsource Is Nothing Then
    Debug.Print "OSP Quotes folder was not found."
  Else
    If oOSPsource.Items.count > 0 Then
      MsgBox "There are items in OSP Quotes.", vbInformation + vbOKOnly
    End If
  End If

  ' close the store
  oNamespace.RemoveStore oDestination

  Set oProgress = Nothing
  Set oDestination = Nothing
'  Set oOSPDestination = Nothing
  Set oOSPsource = Nothing
  Set oSource = Nothing
  Set oStore = Nothing
  Set oNamespace = Nothing
  Exit Sub

HandleError:
  Debug.Print Err.Number
  Debug.Print Err.Description
  Select Case Err.Number
    Case 95
      MsgBox Prompt:=oMailItem.Subject & vbCrLf & vbCrLf & "An email with the above subject line is in conflict." & _
                 vbCrLf & "You will need to resolve the conflict and run Export to Excel again.", _
         Buttons:=vbCritical + vbOKOnly, _
         title:="Conflict Resolution Required"
      oProgress.Hide
      GoTo ExitRoutine
    Case Else
      If Not ErrorHandling.ErrorLog(Err.Number, Err.Description, "Archive The Inbox") Then
        Err.Clear
        Resume
      End If
  End Select
End Sub

Answer 1

Do not use "for each" loop if you are modifying the collection

Change the loop

For Each oMailItem In oSource.Items

to a down "for" loop:

dim oItems = oSource.Items
for I = oItems.Count to 1 step -1
  set oMailItem  = oItems.Item(I)