如何根据Excel筛选结果自动填充附件名与邮件信息中的人名？

完全可以实现根据Excel筛选结果自动提取人员姓名，填充到附件名称、邮件主题和收件人字段。以下是修改后的完整代码，适配筛选后的人员列表：

Sub PrintandEmailFromFilteredList()
    Dim iFolderAdrs As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim filteredRange As Range
    Dim cell As Range
    Dim empName As String
    Dim empEmail As String
    Dim pdfPath As String
    
    ' 设置PDF保存路径
    iFolderAdrs = "C:\Users\CaraBell\"
    ' 指定人员数据所在工作表（假设Sheet1的A列存姓名，B列存邮箱）
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 获取筛选后的可见人员记录（排除第1行表头）
    On Error Resume Next
    Set filteredRange = ws.Range("A2:B" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    ' 检查是否有有效筛选结果
    If filteredRange Is Nothing Then
        MsgBox "未找到筛选后的人员记录！", vbExclamation
        Exit Sub
    End If
    
    ' 初始化Outlook应用
    Set OutApp = CreateObject("Outlook.Application")
    
    ' 遍历每个筛选出的人员
    For Each cell In filteredRange.Columns(1).Cells
        empName = cell.Value
        empEmail = cell.Offset(0, 1).Value ' 提取对应邮箱
        
        ' 跳过空记录
        If empName <> "" And empEmail <> "" Then
            ' 生成带姓名的PDF路径
            pdfPath = iFolderAdrs & empName & " Commission Statement November 2023.pdf"
            
            ' 导出当前工作表为PDF（需导出特定报表可替换ActiveSheet为目标工作表）
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=pdfPath, _
                OpenAfterPublish:=False, IgnorePrintAreas:=False
            
            ' 创建邮件并填充信息
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = empEmail
                .CC = "commissionstatement@mastersofmindset.com"
                .Subject = empName & " Statement November 2023"
                .HTMLBody = "<FONT SIZE = 3>Please see attached for your November 2023 commission statement. All cruise bookings (if you have any) have been reviewed by your line supervisor; any discrepancies please follow up directly with your line supervisor." & .HTMLBody
                .Attachments.Add pdfPath ' 自动添加生成的PDF附件
                .Display ' 如需自动发送可替换为.Send，注意Outlook安全限制
            End With
            
            Set OutMail = Nothing
            MsgBox empName & "的PDF已生成并创建邮件！", vbInformation
        End If
    Next cell
    
    ' 清理对象释放内存
    Set OutApp = Nothing
    MsgBox "所有筛选人员的邮件已处理完成！", vbInformation
End Sub

关键修改说明： #

• 提取筛选结果：通过SpecialCells(xlCellTypeVisible)精准获取Sheet1中筛选后的可见行，适配你的人员列表结构
• 自动填充字段：将提取的姓名自动代入PDF文件名、邮件主题，邮箱直接填入收件人栏
• 循环批量处理：遍历所有筛选出的人员，一次性完成所有邮件的创建和附件生成
• 容错处理：增加无筛选结果、空记录的判断，避免运行报错

注意事项： #

1. 请根据实际表格结构调整姓名、邮箱所在的列号（当前为A列姓名、B列邮箱）
2. 若需导出特定报表工作表，将ActiveSheet替换为目标工作表对象（如ThisWorkbook.Sheets("CommissionReport")）
3. 使用.Send自动发送邮件时，需确保Outlook安全设置允许VBA自动发送邮件

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