VBA批量发送PDF附件邮件时Do循环遗漏首个PDF问题求助

需求与现象 #

• 需求：遍历指定文件夹，根据PDF文件名下划线前的用户标识（如AAA）分组，将对应文件作为附件发送给该用户（邮箱从Excel「EMAIL」工作表的对应列表获取）
• 异常现象：
  • 标识为AAA的邮件能正常添加全部3个PDF附件
  • 处理BBB时，仅添加BBB_222222.pdf、BBB_333333.pdf，遗漏BBB_111111.pdf
  • 处理CCC时，仅添加CCC_888888.pdf、CCC_999999.pdf、CCC_444444.pdf，遗漏CCC_777777.pdf

问题根源 #

代码中内外层循环混用Dir函数导致遍历断点丢失：

1. 外层Do While循环初始读取第一个文件，进入内层循环后，通过Dir()持续获取下一个文件，直到遇到非当前用户的文件才停止
2. 外层循环下一轮启动时，strfile被赋值为内层循环最后得到的文件，直接跳过了当前用户的第一个文件，造成遗漏

修复方案：先分组再发送 #

先将所有文件按用户标识存入字典（键为用户标识，值为对应文件路径列表），再遍历字典逐个发送邮件，彻底避免Dir的遍历顺序问题。

修复后的完整代码 #

Sub emailreports()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim signature, mfe, sto As String
    Dim emaillastrow, x As Long
    Dim fso As Scripting.FileSystemObject
    Set fso = New FileSystemObject
    Dim folder, strfile As String
    Dim fileDict As Object ' 存储用户标识与对应文件路径的字典
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Application.AutoRecover.Enabled = False
    
    folder = Worksheets("START").Range("A14")
    strfile = Dir(folder & "*.pdf") ' 仅筛选PDF文件
    
    ' 初始化字典
    Set fileDict = CreateObject("Scripting.Dictionary")
    
    ' 第一步：遍历所有PDF，按用户标识分组存入字典
    Do While Len(strfile) > 0
        Dim fullPath As String
        fullPath = folder & strfile
        Dim fileName As String
        fileName = fso.GetBaseName(fullPath)
        mfe = Left(fileName, InStr(fileName, "_") - 1)
        
        ' 将文件路径添加到对应用户的列表中
        If Not fileDict.Exists(mfe) Then
            fileDict.Add mfe, New Collection
        End If
        fileDict(mfe).Add fullPath
        
        strfile = Dir
    Loop
    
    ' 检查文件夹是否存在
    If Dir(folder, vbDirectory) = "" Then
        MsgBox "PDF目标路径不存在。", vbCritical, "路径错误"
        Exit Sub
    End If
    
    ' 获取邮箱列表最后一行
    emaillastrow = Worksheets("EMAIL").Range("A1000000").End(xlUp).Row
    
    ' 第二步：遍历字典，逐个用户发送邮件
    For Each mfe In fileDict.Keys
        ' 获取用户对应的邮箱
        sto = ""
        For x = 2 To emaillastrow
            If mfe = Worksheets("EMAIL").Range("A" & x) Then
                sto = sto & ";" & Worksheets("EMAIL").Range("B" & x)
            End If
        Next
        
        ' 去除开头的分号
        If Left(sto, 1) = ";" Then sto = Mid(sto, 2)
        
        ' 创建邮件
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        
        On Error Resume Next
        With OutMail
            .Display ' 显示邮件以获取签名
            .To = LCase(sto)
            .CC = ""
            .BCC = ""
            .Subject = "Test subject text"
            
            ' 添加所有对应附件
            Dim filePath As Variant
            For Each filePath In fileDict(mfe)
                .Attachments.Add filePath
            Next
            
            ' 替换邮件内容
            .signature.Delete
            .HTMLBody = "<font face=""arial"" style=""font-size:10pt;"">" & "Test email body text" & .HTMLBody
            .Display
        End With
        On Error GoTo 0
        
        ' 释放对象
        Set OutMail = Nothing
        Set OutApp = Nothing
    Next mfe
    
    ' 恢复Excel设置
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    Application.AutoRecover.Enabled = True
    
    ' 释放字典
    Set fileDict = Nothing
End Sub

关键优化点 #

1. 使用Scripting.Dictionary提前按用户分组存储所有文件路径，避免Dir遍历的断点问题
2. 单独拆分「文件分组」和「发送邮件」两个步骤，逻辑更清晰，便于维护
3. 处理邮箱字符串时去除开头多余的分号，避免收件人格式错误
4. 仅遍历PDF文件（Dir(folder & "*.pdf")），减少无效文件处理

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