Outlook & Excel VBA- malfunctioning For each/Next

[jmthompson]

Hey guys,
Each night, I should receive about 120 system generated e-mails to confirm that processes complete successfully. I am attempting to put together code to identify any missing notifications.

My plan is to export the e-mail subjects to Excel, compare to a list, identify any missing items and e-mail the missing items back to myself.

I then want to move the e-mails to another folder and mark as read.

So far, I have the code to export to Excel.

I'll get to the code in the Excel workbook in a bit. I am struggling with a piece of the Outlook code to move the items to a folder and mark as read.
I know this isn't an Outlook forum, but hoping somebody may be able to help:

For some reason, the highlighted code only runs through about 1/2 of the items in my folder, it just stops going to the next item and proceeds with the rest of the code.

Option Explicit

Sub ExportToExcel()

  On Error GoTo ErrHandler

  Dim appExcel As Excel.Application
  Dim wkb As Excel.Workbook
  Dim wks As Excel.Worksheet
  Dim rng As Excel.Range
  Dim strSheet As String
  Dim strPath As String
  Dim intRowCounter As Integer
  Dim intColumnCounter As Integer
  Dim msg As Outlook.MailItem
  Dim nms As Outlook.NameSpace
  Dim fld As Outlook.MAPIFolder
  Dim itm As Object
  
  strSheet = "OutlookItems.xls"
  strPath = "H:\my macros\"
  strSheet = strPath & strSheet
  Debug.Print strSheet
  
  'Select export folder
  Set nms = Application.GetNamespace("MAPI")
  Set fld = nms.Folders("Mailbox - Thompson, Jennifer").Folders("Inbox").Folders("Hyperion Notifications").Folders("Nightly Rebuilds")
  
  'Handle potential errors with Select Folder dialog box.
  If fld Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
     "Error"
    Exit Sub
  ElseIf fld.DefaultItemType <> olMailItem Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
     "Error"
    Exit Sub
  ElseIf fld.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, _
     "Error"
    Exit Sub
  End If
  
  'Open and activate Excel workbook.
  Set appExcel = CreateObject("Excel.Application")
  appExcel.Workbooks.Open (strSheet)
  Set wkb = appExcel.ActiveWorkbook
  Set wks = wkb.Sheets(1)
  wks.Activate
  appExcel.Application.Visible = True
   
  'Copy field items in mail folder.
  For Each itm In fld.Items
    intColumnCounter = 1
    Set msg = itm
    intRowCounter = intRowCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.Subject
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.SentOn
    intColumnCounter = intColumnCounter + 1
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = msg.ReceivedTime
  Next itm
  Set appExcel = Nothing
  Set wkb = Nothing
  Set wks = Nothing
  Set rng = Nothing
  Set msg = Nothing
  Set nms = Nothing
  Set fld = Nothing
  Set itm = Nothing
  
   Dim fld2 As Outlook.MAPIFolder
   Dim fld3 As Outlook.MAPIFolder


    Set nms = Application.GetNamespace("MAPI")
    Set fld2 = nms.Folders("Mailbox - Thompson, Jennifer").Folders("Inbox").Folders("Hyperion Notifications").Folders("Nightly Rebuilds").Folders("Old")
Set fld3 = nms.Folders("Mailbox - Thompson, Jennifer").Folders("Inbox").Folders("Hyperion Notifications").Folders("Nightly Rebuilds")


    If fld2 Is Nothing Then
        MsgBox "This folder doesn’t exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
    End If
 
    If fld3.Items.Count = 0 Then

        Exit Sub
    End If
    
    For Each msg In fld3.Items
            If msg.Class = olMail Then
                msg.UnRead = False
                msg.Move fld
            End If
    Next msg
 
    Set msg = Nothing
    Set fld2 = Nothing
    Set fld3 = Nothing
    Set nms = Nothing
  
  Exit Sub

ErrHandler:
  If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, _
     "Error"
  Else
    MsgBox Err.Number & "; Description: ", vbOKOnly, _
     "Error"
  End If
  Set appExcel = Nothing
  Set wkb = Nothing
  Set wks = Nothing
  Set rng = Nothing
  Set msg = Nothing
  Set nms = Nothing
  Set fld = Nothing
  Set itm = Nothing


End Sub

 

[jmthompson]

Clumsy solve, I added a Do While loop around the problem code to force a repeat until the folder is empty