Loop to auto reply to all email in a folder while looping to match a subject in Excel cells

Question

I created the below code to reply based on the email subject listed in Excel cells. It cannot loop through the cells.

It can only reply to one email and cannot continue to the next step.

Sub Display()

Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Dim IsExecuted As Boolean
Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
    Signature = Signature & Dir$(Signature & "*.htm")
Else:
    Signature = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)

IsExecuted = False

i = 2
For Each olMail In Fldr.Items
    If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then

        With olMail.Reply
            .HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
            .Display
        End With

        i = i + 1
    End If

Next olMail

End Sub

score 0 · Answer 1 · answered Jun 03 '22 at 15:24

You change rows before checking all items.

You could move i = i + 1 after Next olMail but you would need additional code to complete the second loop.

Instead apply another For loop.

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant


Sub Display()

' Early binding
' Set reference to Microsoft Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.Folder

Dim olMail As Object

Dim i As Long
Dim lastRow As Long

Dim Signature As String

Signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(Signature, vbDirectory) <> vbNullString Then
    Signature = Signature & Dir$(Signature & "*.htm")
Else
    Signature = ""
End If

Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderToDo)

' https://stackoverflow.com/questions/38882321/better-way-to-find-last-used-row
lastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Debug.Print
Debug.Print "lastRow:" & lastRow

For i = 2 To lastRow

    Debug.Print
    Debug.Print i & "- " & ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
    
    For Each olMail In Fldr.Items
        
        Debug.Print "  " & olMail.Subject
        
        If InStr(olMail.Subject, ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value) <> 0 Then
            With olMail.Reply
                .HTMLBody = "<p>" & "Dear All," & "</p><br>" & ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value & "</p><br>" & Signature & .HTMLBody
                Debug.Print "*** match ***"
                .Display
            End With
        End If

    Next olMail
    
Next

End Sub

Thank you for the help. I have tried it and it works :) – Novia Jun 04 '22 at 11:25 — Novia, Jun 04 '22 at 11:25

score 0 · Answer 2 · answered Jun 04 '22 at 14:49

Outlook folders may contain different kind of items. So, when you iterate over all items in the folder you may deal with different items - appointments, documents, notes and etc. To make sure that you deal with mail items only I'd recommend checking the MessageClass property of the item before accessing item-specific properties at runtime. Otherwise, an error will be raised and your loop will never come to the end.

Loop to auto reply to all email in a folder while looping to match a subject in Excel cells

2 Answers2