VBA实现Outlook邮件匹配Excel主题自动回复循环失效问题

代码遍历逻辑顺序错误，同时存在多处边界判断缺失：

• 当前逻辑为外层循环遍历Outlook邮件，靠变量i逐行递增读取Excel主题做匹配，这种逻辑要求Outlook内邮件排序必须和Excel行顺序完全一致，只要顺序错位，后续所有匹配都会直接失效，最终表现就是只回复第一封匹配到的邮件就停止
• 未做非邮件对象判断，遍历到文件夹内的会议邀请、任务条目时会直接抛错中断
• 未做空单元格判断，i递增到空行后会拿空值做匹配，永远无法命中
• 匹配逻辑未忽略文本大小写，主题大小写不一致时会匹配失败

将遍历顺序倒置，外层逐行读取Excel配置，内层到Outlook文件夹查找对应邮件，从根源避免顺序错位问题，同时修复所有边界异常：

Sub AutoReplyByExcelConfig()
    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim olItem As Variant
    Dim olMail As Outlook.MailItem
    Dim i As Long
    Dim Signature As String
    Dim ws As Worksheet
    Dim searchSubject As String
    
    ' 初始化邮件签名
    Signature = Environ("appdata") & "\Microsoft\Signatures\"
    If Dir(Signature, vbDirectory) <> vbNullString Then
        Signature = Signature & Dir$(Signature & "*.htm")
        If Signature <> Environ("appdata") & "\Microsoft\Signatures\" Then
            Signature = CreateObject("Scripting.FileSystemObject").GetFile(Signature).OpenAsTextStream(1, -2).ReadAll
        Else
            Signature = ""
        End If
    Else
        Signature = ""
    End If
    
    ' 初始化Outlook相关对象
    Set olApp = New Outlook.Application
    Set olNs = olApp.GetNamespace("MAPI")
    Set Fldr = olNs.GetDefaultFolder(olFolderToDo)
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    i = 2
    ' 外层遍历Excel配置行，A列空行即停止
    Do While Trim(ws.Cells(i, 1).Value) <> ""
        searchSubject = Trim(ws.Cells(i, 1).Value)
        ' 内层遍历Outlook文件夹查找匹配邮件
        For Each olItem In Fldr.Items
            ' 先判断是否为邮件项，避免非邮件对象触发报错
            If TypeName(olItem) = "MailItem" Then
                Set olMail = olItem
                ' 模糊匹配主题，不区分大小写
                If InStr(1, olMail.Subject, searchSubject, vbTextCompare) <> 0 Then
                    With olMail.Reply
                        .HTMLBody = "<p>Dear All,</p><br>" & _
                                    "<p>" & ws.Cells(i, 2).Value & "</p><br>" & _
                                    Signature & .HTMLBody
                        .Display ' 确认内容无误可替换为.Send实现自动发送
                    End With
                    ' 同主题仅回复第一封时保留，需回复所有同主题邮件则删除此行
                    Exit For
                End If
            End If
        Next olItem
        i = i + 1
    Loop
    
    ' 释放对象
    Set olMail = Nothing
    Set Fldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
    Set ws = Nothing
End Sub

• 如果需要对同主题的所有邮件都回复，删除代码中Exit For行即可
• 如果需要主题完全匹配而非模糊包含，把InStr(1, olMail.Subject, searchSubject, vbTextCompare) <> 0替换为olMail.Subject = searchSubject
• 新增了签名路径异常判断，本地不存在HTM格式签名文件时不会触发运行错误

内容的提问来源于stack exchange，提问作者Novia