以下是一个示例VBA代码,用于将不同的数据透视表发送到不同的电子邮件地址。
Sub SendPivotTablesByEmail()
Dim wb As Workbook
Dim ws As Worksheet
Dim pt As PivotTable
Dim rng As Range
Dim wsEmail As Worksheet
Dim rngEmail As Range
Dim cell As Range
Dim outlookApp As Object
Dim outlookMail As Object
' 打开目标工作簿
Set wb = Workbooks.Open("C:\路径\目标工作簿.xlsx")
' 设置目标工作表
Set ws = wb.Worksheets("目标工作表")
' 遍历每个数据透视表
For Each pt In ws.PivotTables
' 清除之前的筛选
pt.ClearAllFilters
' 设置筛选条件(可根据需要修改)
pt.PivotFields("字段1").CurrentPage = "条件1"
pt.PivotFields("字段2").CurrentPage = "条件2"
' 将数据透视表复制到新工作簿
pt.TableRange1.Copy
Set rng = ThisWorkbook.Worksheets.Add().Range("A1")
rng.PasteSpecial xlPasteValues
' 保存新工作簿并关闭
rng.Parent.SaveAs "C:\路径\" & pt.Name & ".xlsx"
rng.Parent.Close False
' 创建 Outlook 应用程序对象
Set outlookApp = CreateObject("Outlook.Application")
' 创建新邮件
Set outlookMail = outlookApp.CreateItem(0)
' 设置邮件主题和收件人地址(可根据需要修改)
With outlookMail
.Subject = "数据透视表: " & pt.Name
.To = "收件人1@example.com"
.CC = "抄送人@example.com"
' 正文内容(可根据需要修改)
.Body = "请查阅附件中的数据透视表。"
' 添加附件
.Attachments.Add "C:\路径\" & pt.Name & ".xlsx"
' 发送邮件
.Send
End With
' 删除附件文件
Kill "C:\路径\" & pt.Name & ".xlsx"
Next pt
' 关闭目标工作簿
wb.Close False
' 清除对象引用
Set outlookMail = Nothing
Set outlookApp = Nothing
Set rng = Nothing
Set ws = Nothing
Set wb = Nothing
End Sub
请确保以下操作:
您可以将此代码复制并粘贴到 Excel 的 VBA 编辑器中(按 ALT + F11 打开)的模块中。之后,您可以通过运行 VBA 宏“SendPivotTablesByEmail”来执行代码。