VBA代码修改：实现循环打开匹配ID的全部邮件

原代码的核心问题是找到第一个匹配项后就执行Exit Sub直接终止程序，因此仅能打开第一封匹配邮件。同时每次循环重复创建Outlook实例也存在效率问题，优化后的代码如下：

Private Sub CommandButton8showemail_Click()
    Dim wsArch As Worksheet
    Dim lastrow, a As Long
    Dim strEmailLoc As String
    Dim OutMejlik As Outlook.Application
    Dim msg As Outlook.MailItem
    Dim foundMatch As Boolean ' 标记是否找到匹配项

    Set wsArch = ThisWorkbook.Sheets("Emails_arch")
    lastrow = wsArch.Range("A" & Rows.Count).End(xlUp).Row
    
    ' 提前创建Outlook实例，避免重复创建
    Set OutMejlik = CreateObject("Outlook.Application")
    foundMatch = False

    With wsArch
        For a = lastrow To 2 Step -1
            If .Cells(a, 1).Value = TextBox1INC.Text Then
                strEmailLoc = .Cells(a, 2).Value
                Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
                msg.Display
                foundMatch = True
                ' 移除Exit Sub，让循环继续遍历所有行查找匹配项
            End If
        Next a
    End With
    
    ' 未找到匹配项时提示用户
    If Not foundMatch Then
        MsgBox "未找到匹配的邮件记录", vbInformation
    End If
    
    ' 释放对象，避免内存占用
    Set msg = Nothing
    Set OutMejlik = Nothing
    Set wsArch = Nothing
End Sub

关键修改说明： #

• 移除Exit Sub：让循环完整遍历所有行，找到所有匹配ID的邮件并逐一打开。
• 提前创建Outlook实例：避免每次匹配都重复初始化Outlook，提升运行效率。
• 添加匹配标记：用于最终判断是否存在匹配项，给用户直观的反馈。
• 补充对象释放：遵循VBA编程规范，减少不必要的内存占用。

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