ARTICLE · 1277597
Excel-VBA月报报表挨个发邮件太耗时间!VBA读取表格,自动填正文、带上附件一键推送
Excel-VBA月报报表挨个发邮件太耗时间!VBA读取表格,自动填正文、带上附件一键推送每月固定给客户、部门发报表，复制邮箱、粘贴文字、选择附件、点击发送，重复机械操作。这套基于Outlook的VBA，读取当前行信息，自动生成邮件正文，自动绑定附件，一键批量发送。 前提：电脑安装Outlook并正常登录账号，WPS邮件、网页邮箱不适用。 ✅ 功能说明 1. 读取表格里：收件邮箱、名称、备注、附件路径 2. 自动拼接邮件主题、自定义正文 3. 自动绑定附件，支持单个附件 4. 邮件先弹出预览，确认无误再手动点发送 5. 可改成静默自动发送 ❤️完整代码 Sub Outlook自动发邮件带附件()
Dim olApp As Object
Dim olMail As Object
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim sendMail As String, name As String, subject As String, body As String, fileLink As String
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'====参数区：表头在第1行，数据从第2行开始====
'A列：姓名 B列：收件邮箱 C列：附件完整路径 D列：邮件主题
'==========================================
If lastRow < 2 Then
MsgBox "没有待发送数据！", vbExclamation
Exit Sub
End If
Set olApp = CreateObject("Outlook.Application")
For i = 2 To lastRow
sendMail = Trim(ws.Cells(i, "B").Value)
name = Trim(ws.Cells(i, "A").Value)
subject = Trim(ws.Cells(i, "D").Value)
fileLink = Trim(ws.Cells(i, "C").Value)
If sendMail <> "" Then
Set olMail = olApp.CreateItem(0)
'邮件正文，可自由修改排版
body = name & "：" & vbCrLf & vbCrLf & _
"您好，对应的报表已附上，请查收。" & vbCrLf & _
"如有疑问随时沟通。" & vbCrLf & vbCrLf & _
"顺颂商祺"
With olMail
.To = sendMail
.Subject = subject
.Body = body
'判断附件是否存在
If Dir(fileLink) <> "" Then
.Attachments.Add fileLink
End If
.Display '弹出邮件窗口确认；改成 .Send 自动发送，慎用
End With
End If
Next i
MsgBox "全部邮件生成完毕，请核对发送！", vbInformation
Set olMail = Nothing
Set olApp = Nothing
End Sub 使用说明： 表格列规划（第1行表头） A：收件人名称｜B：邮箱地址｜C：附件完整路径（D:\报表\xxx.xlsx）｜D：邮件主题 注意事项 1. 必须是Outlook客户端，企业邮箱、个人邮箱都要先在Outlook登录好 2. .Display 弹窗预览，安全优先；改成 .Send 会直接发出去，出错很难撤回 3. 附件路径不能错，路径里不要有特殊字符 4. 正文文字可以自己改写换行、增加表格内容 vba专业开发，关注收藏不迷路，excel办公自动化，解放双手提高效率 Excel-vba批量打印：按A列分组，自动分页打印，每组单独一页 VBA一键拆分工作表！按列自动分Sheet/分独立文件，十万行数据不卡顿 VBA神器批量跨文件查询回填，数组版，替代VLOOKUP，十万行提速 别再手动找数据！Excel万能查询公式 轻松掌握Excel数据透视，释放数据潜力
Dim olApp As Object
Dim olMail As Object
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim sendMail As String, name As String, subject As String, body As String, fileLink As String
Set ws = ActiveSheet
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'====参数区：表头在第1行，数据从第2行开始====
'A列：姓名 B列：收件邮箱 C列：附件完整路径 D列：邮件主题
'==========================================
If lastRow < 2 Then
MsgBox "没有待发送数据！", vbExclamation
Exit Sub
End If
Set olApp = CreateObject("Outlook.Application")
For i = 2 To lastRow
sendMail = Trim(ws.Cells(i, "B").Value)
name = Trim(ws.Cells(i, "A").Value)
subject = Trim(ws.Cells(i, "D").Value)
fileLink = Trim(ws.Cells(i, "C").Value)
If sendMail <> "" Then
Set olMail = olApp.CreateItem(0)
'邮件正文，可自由修改排版
body = name & "：" & vbCrLf & vbCrLf & _
"您好，对应的报表已附上，请查收。" & vbCrLf & _
"如有疑问随时沟通。" & vbCrLf & vbCrLf & _
"顺颂商祺"
With olMail
.To = sendMail
.Subject = subject
.Body = body
'判断附件是否存在
If Dir(fileLink) <> "" Then
.Attachments.Add fileLink
End If
.Display '弹出邮件窗口确认；改成 .Send 自动发送，慎用
End With
End If
Next i
MsgBox "全部邮件生成完毕，请核对发送！", vbInformation
Set olMail = Nothing
Set olApp = Nothing
End Sub
