根据电子表格中的详细信息和电子表格中的 copy/paste 表将电子邮件自动发送到相应的电子邮件中
Automate Email based on details in spreadsheet and copy/paste tables from spreadsheet into corresponding email
感谢您花时间尝试帮助我完成这个项目。
我有一些 vba 可以向我的电子表格中的每个收件人发送一封电子邮件，并将来自电子表格的文本信息包含在正文中。这段代码效果很好。这是我卡住的部分...
工作簿包含我想过滤的几个 table 和 copy/paste 到每封电子邮件中，但每个 table 的数据需要过滤为适用的数据给每个收件人。
例如：
该电子邮件将发送给区域领导者，并包含其区域的整体分数。
我有 1 个 table，其中包括可以按地区过滤的经理分数和
在第二个选项卡上，每个区域都有一个 table，按服务类型向下钻取分数。
所以对于西南地区的领导，我想过滤 table 1 以仅显示西南地区的经理，copy/paste table 直接进入电子邮件然后去到服务类型 tables 并复制 SouthWest table 并粘贴到电子邮件中。
我要完成的最后一步是将驻留在单独选项卡上的员工级别详细信息复制到工作簿并将其附加到电子邮件中。这也需要针对每个地区的员工。
我不知道这在我的代码中是否可行，或者是否有实现它的聪明方法。感谢您愿意提供的任何帮助或见解！我附上了一个示例文件，下面是我当前使用的电子邮件代码。我还有一些代码可以根据地区过滤数据，这些代码可能有用也可能没用。
Sub SendMailtoRFE()
Dim outapp As New Outlook.Application
Dim outmail As Outlook.Mailitem
Dim wks As Worksheet
Dim i As Integer
Dim sFile1 As String
Dim TempFilePath As String
Environ ("UserProfile")
Set outapp = CreateObject("outlook.application")
sFile1 = "Infographic"
TempFilePath = Environ$("temp") & "Roadside Assistance " 'FIND OUT HOW TO CLEAN UP THE NAME: "Temp" added to file name
ActiveWorkbook.Sheets(sFile1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sFile1 & ".pdf"
On Error Resume Next
For i = 3 To wks.Range("A" & Rows.Count).End(xlUp).Row
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = wks.Range("C" & i).Value
.Subject = wks.Range("A" & i).Value & " Region Roadside Assistance YTD Communication"
.HTMLBody = "Dear " & wks.Range("C" & i).Value & "," & "<br></br>" & _
"You've shared how important Roadside Assistance is for your personal auto clients. As one of the highest frequency types of losses, success or failure " & _
"here may be seen as a signal of the overall value of the program." & "<br></br><br></br>" & _
"Here are the results for clients in your area who completed a survey. Year to date, the NPS was " & FormatPercent(wks.Range("K" & i).Value, 0) & _
" based on " & wks.Range("H" & i).Value & " total responses." & _
" The overall score for all regions is " & FormatPercent(wks.Range("K12").Value, 0) & "." & "<br></br><br></br>" & _
"Below are a few additional details to help you understand your region's score. " & _
"Please follow up with any questions or concerns." & "<br></br><br></br>" & vbNewLine & _
"**Please note, the table containing MLGA scores shows only the MLGA's where 5 or more survey responses were received.**"
.Attachments.Add (TempFilePath & sFile1 & ".pdf")
.display
End With
On Error GoTo 0
Set outmail = Nothing
Next i
Set outapp = Nothing
End Sub
''Filter Region on the MLGA Tow NPS Score Tab
Sub FilterSouthWest()
Dim wks As Worksheet
Set wks = Sheets("MLGA TOW NPS Score")
With wks.Range("A2:C2")
.AutoFilter Field:=3, Criteria1:="9A"
End With
End Sub
使用 .SpecialCells(xlCellTypeVisible) 将过滤后的 table 和 copy/paste 的范围设置到使用 WordEditor 的电子邮件中。要插入 html 文本，请创建一个临时文件并使用 .InsertFile，这会将 html 格式转换为 word 格式。根据数据量，您可能需要在 copy/paste 操作之间添加等待时间。
Option Explicit
Sub SendMailtoRFE()
'sheet names
Const PDF = "Infographic" ' attachment
Const WS_S = "MLGA TOW NPS Score" ' filtered score data
Const WS_R = "Regions" ' names and emails
Const WS_T = "Tables" ' Regions Tables
Dim ws As Worksheet, sPath As String, sPDFname As String
Dim lastrow As Long, i As Long, n As Long
' region code for filter
Dim dictRegions As Object, region
Set dictRegions = CreateObject("Scripting.Dictionary")
With dictRegions
.Add "NorthEast", "6A"
.Add "NorthWest", "7A"
.Add "SouthEast", "8A"
.Add "SouthWest", "9A"
End With
sPath = Environ$("temp") & "\"
sPDFname = sPath & "Roadside Assistance " & PDF & ".pdf"
Sheets(PDF).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPDFname
Dim outapp As Outlook.Application
Dim outmail As Outlook.Mailitem
Dim outInsp As Object, oWordDoc
Dim wsRegion As Worksheet
Dim sRegion As String, sEmailAddr As String, rngScore As Range
Dim Table1 As Range, Table2 As Range, tmpHTML As String
' scores
With Sheets(WS_S)
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngScore = .Range("A2:G" & lastrow) ' 5 columns
End With
' open outlook
Set outapp = New Outlook.Application
' regions
Set wsRegion = Sheets(WS_R)
lastrow = wsRegion.Cells(wsRegion.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastrow '
sRegion = wsRegion.Range("A" & i).Value
sEmailAddr = wsRegion.Range("C" & i).Value
tmpHTML = HTMLFile(wsRegion, i)
' region
With rngScore
.AutoFilter
.AutoFilter Field:=3, Criteria1:=dictRegions(sRegion) ' filter col C
Set Table1 = .SpecialCells(xlCellTypeVisible)
End With
' Service Type Table
Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' Table named same as region
'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address
Set outmail = outapp.CreateItem(olMailItem)
n = n + 1
With outmail
.To = sEmailAddr
.Subject = sRegion & " Region Roadside Assistance YTD Communication"
.Attachments.Add sPDFname
.display
End With
Set outInsp = outmail.GetInspector
Set oWordDoc = outInsp.WordEditor
'Wait 1
With oWordDoc
.Content.Delete
.Paragraphs.Add.Range.InsertFile tmpHTML, Link:=False, Attachment:=False
Table1.Copy
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = vbCrLf ' blank line
'Wait 1
Table2.Copy
.Paragraphs.Add.Range.Paste
'Wait 1
End With
Application.CutCopyMode = False
Set oWordDoc = Nothing
Set outInsp = Nothing
Set outmail = Nothing
' delete temp html file
On Error Resume Next
Kill tmpHTML
On Error GoTo 0
'Wait 1
Next
' end
Sheets(WS_S).AutoFilterMode = False
Set outapp = Nothing
AppActivate Application.Caption ' back to excel
MsgBox n & " Emails created", vbInformation
End Sub
Function HTMLFile(ws As Worksheet, i As Long) As String
Const CSS = "p{font:14px Verdana};h1{font:14px Verdana Bold};"
' template
Dim s As String
s = "<html><style>" & CSS & "</style><h1>Dear #NAME#,</h1>" & _
"<p>You've shared how important Roadside Assistance is for your personal auto clients.<br/>" & vbLf & _
"As one of the highest frequency types of losses, success or failure " & vbLf & _
"here may be seen as a signal of the overall value of the program.</p>" & vbLf & _
"<p>Here are the results for clients in your area who completed a survey.</p> " & vbLf & _
"<li>Year to date, the NPS was <b>#NPS_YTD#</b> " & vbLf & _
"based on <b>#RESPONSES#</b> total responses.</li> " & vbLf & _
"<li>The overall score for all regions is <b>#NPS_ALL#</b>,</li>" & vbLf & _
"<p>Below are a few additional details to help you understand your region's score. " & vbLf & _
"Please follow up with any questions or concerns." & "</p>" & vbNewLine & vbLf & _
"<p><i>**Please note, the table containing MLGA scores shows only the MLGA's where 5 " & vbLf & _
"or more survey responses were received.**</i></p></html>"
s = Replace(s, "#NAME#", ws.Cells(i, "C"))
s = Replace(s, "#NPS_YTD#", FormatPercent(ws.Cells(i, "K"), 0))
s = Replace(s, "#RESPONSES#", ws.Cells(i, "H"))
s = Replace(s, "#NPS_ALL#", FormatPercent(ws.Cells(12, "K"), 0))
Dim ff: ff = FreeFile
HTMLFile = Environ$("temp") & "\" & Format(Now(), "~yyyymmddhhmmss") & ".htm"
Open HTMLFile For Output As #ff
Print #ff, s
Close #ff
End Function
Sub Wait(n As Long)
Dim t As Date
t = DateAdd("s", n, Now())
Do While Now() < t
DoEvents
Loop
End Sub
感谢您花时间尝试帮助我完成这个项目。
我有一些 vba 可以向我的电子表格中的每个收件人发送一封电子邮件，并将来自电子表格的文本信息包含在正文中。这段代码效果很好。这是我卡住的部分...
工作簿包含我想过滤的几个 table 和 copy/paste 到每封电子邮件中，但每个 table 的数据需要过滤为适用的数据给每个收件人。
例如： 该电子邮件将发送给区域领导者，并包含其区域的整体分数。 我有 1 个 table，其中包括可以按地区过滤的经理分数和 在第二个选项卡上，每个区域都有一个 table，按服务类型向下钻取分数。
所以对于西南地区的领导，我想过滤 table 1 以仅显示西南地区的经理，copy/paste table 直接进入电子邮件然后去到服务类型 tables 并复制 SouthWest table 并粘贴到电子邮件中。
我要完成的最后一步是将驻留在单独选项卡上的员工级别详细信息复制到工作簿并将其附加到电子邮件中。这也需要针对每个地区的员工。
我不知道这在我的代码中是否可行，或者是否有实现它的聪明方法。感谢您愿意提供的任何帮助或见解！我附上了一个示例文件，下面是我当前使用的电子邮件代码。我还有一些代码可以根据地区过滤数据，这些代码可能有用也可能没用。
Sub SendMailtoRFE()
Dim outapp As New Outlook.Application
Dim outmail As Outlook.Mailitem
Dim wks As Worksheet
Dim i As Integer
Dim sFile1 As String
Dim TempFilePath As String
Environ ("UserProfile")
Set outapp = CreateObject("outlook.application")
sFile1 = "Infographic"
TempFilePath = Environ$("temp") & "Roadside Assistance " 'FIND OUT HOW TO CLEAN UP THE NAME: "Temp" added to file name
ActiveWorkbook.Sheets(sFile1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sFile1 & ".pdf"
On Error Resume Next
For i = 3 To wks.Range("A" & Rows.Count).End(xlUp).Row
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = wks.Range("C" & i).Value
.Subject = wks.Range("A" & i).Value & " Region Roadside Assistance YTD Communication"
.HTMLBody = "Dear " & wks.Range("C" & i).Value & "," & "<br></br>" & _
"You've shared how important Roadside Assistance is for your personal auto clients. As one of the highest frequency types of losses, success or failure " & _
"here may be seen as a signal of the overall value of the program." & "<br></br><br></br>" & _
"Here are the results for clients in your area who completed a survey. Year to date, the NPS was " & FormatPercent(wks.Range("K" & i).Value, 0) & _
" based on " & wks.Range("H" & i).Value & " total responses." & _
" The overall score for all regions is " & FormatPercent(wks.Range("K12").Value, 0) & "." & "<br></br><br></br>" & _
"Below are a few additional details to help you understand your region's score. " & _
"Please follow up with any questions or concerns." & "<br></br><br></br>" & vbNewLine & _
"**Please note, the table containing MLGA scores shows only the MLGA's where 5 or more survey responses were received.**"
.Attachments.Add (TempFilePath & sFile1 & ".pdf")
.display
End With
On Error GoTo 0
Set outmail = Nothing
Next i
Set outapp = Nothing
End Sub
''Filter Region on the MLGA Tow NPS Score Tab
Sub FilterSouthWest()
Dim wks As Worksheet
Set wks = Sheets("MLGA TOW NPS Score")
With wks.Range("A2:C2")
.AutoFilter Field:=3, Criteria1:="9A"
End With
End Sub
使用 .SpecialCells(xlCellTypeVisible) 将过滤后的 table 和 copy/paste 的范围设置到使用 WordEditor 的电子邮件中。要插入 html 文本，请创建一个临时文件并使用 .InsertFile，这会将 html 格式转换为 word 格式。根据数据量，您可能需要在 copy/paste 操作之间添加等待时间。
Option Explicit
Sub SendMailtoRFE()
'sheet names
Const PDF = "Infographic" ' attachment
Const WS_S = "MLGA TOW NPS Score" ' filtered score data
Const WS_R = "Regions" ' names and emails
Const WS_T = "Tables" ' Regions Tables
Dim ws As Worksheet, sPath As String, sPDFname As String
Dim lastrow As Long, i As Long, n As Long
' region code for filter
Dim dictRegions As Object, region
Set dictRegions = CreateObject("Scripting.Dictionary")
With dictRegions
.Add "NorthEast", "6A"
.Add "NorthWest", "7A"
.Add "SouthEast", "8A"
.Add "SouthWest", "9A"
End With
sPath = Environ$("temp") & "\"
sPDFname = sPath & "Roadside Assistance " & PDF & ".pdf"
Sheets(PDF).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPDFname
Dim outapp As Outlook.Application
Dim outmail As Outlook.Mailitem
Dim outInsp As Object, oWordDoc
Dim wsRegion As Worksheet
Dim sRegion As String, sEmailAddr As String, rngScore As Range
Dim Table1 As Range, Table2 As Range, tmpHTML As String
' scores
With Sheets(WS_S)
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngScore = .Range("A2:G" & lastrow) ' 5 columns
End With
' open outlook
Set outapp = New Outlook.Application
' regions
Set wsRegion = Sheets(WS_R)
lastrow = wsRegion.Cells(wsRegion.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastrow '
sRegion = wsRegion.Range("A" & i).Value
sEmailAddr = wsRegion.Range("C" & i).Value
tmpHTML = HTMLFile(wsRegion, i)
' region
With rngScore
.AutoFilter
.AutoFilter Field:=3, Criteria1:=dictRegions(sRegion) ' filter col C
Set Table1 = .SpecialCells(xlCellTypeVisible)
End With
' Service Type Table
Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' Table named same as region
'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address
Set outmail = outapp.CreateItem(olMailItem)
n = n + 1
With outmail
.To = sEmailAddr
.Subject = sRegion & " Region Roadside Assistance YTD Communication"
.Attachments.Add sPDFname
.display
End With
Set outInsp = outmail.GetInspector
Set oWordDoc = outInsp.WordEditor
'Wait 1
With oWordDoc
.Content.Delete
.Paragraphs.Add.Range.InsertFile tmpHTML, Link:=False, Attachment:=False
Table1.Copy
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = vbCrLf ' blank line
'Wait 1
Table2.Copy
.Paragraphs.Add.Range.Paste
'Wait 1
End With
Application.CutCopyMode = False
Set oWordDoc = Nothing
Set outInsp = Nothing
Set outmail = Nothing
' delete temp html file
On Error Resume Next
Kill tmpHTML
On Error GoTo 0
'Wait 1
Next
' end
Sheets(WS_S).AutoFilterMode = False
Set outapp = Nothing
AppActivate Application.Caption ' back to excel
MsgBox n & " Emails created", vbInformation
End Sub
Function HTMLFile(ws As Worksheet, i As Long) As String
Const CSS = "p{font:14px Verdana};h1{font:14px Verdana Bold};"
' template
Dim s As String
s = "<html><style>" & CSS & "</style><h1>Dear #NAME#,</h1>" & _
"<p>You've shared how important Roadside Assistance is for your personal auto clients.<br/>" & vbLf & _
"As one of the highest frequency types of losses, success or failure " & vbLf & _
"here may be seen as a signal of the overall value of the program.</p>" & vbLf & _
"<p>Here are the results for clients in your area who completed a survey.</p> " & vbLf & _
"<li>Year to date, the NPS was <b>#NPS_YTD#</b> " & vbLf & _
"based on <b>#RESPONSES#</b> total responses.</li> " & vbLf & _
"<li>The overall score for all regions is <b>#NPS_ALL#</b>,</li>" & vbLf & _
"<p>Below are a few additional details to help you understand your region's score. " & vbLf & _
"Please follow up with any questions or concerns." & "</p>" & vbNewLine & vbLf & _
"<p><i>**Please note, the table containing MLGA scores shows only the MLGA's where 5 " & vbLf & _
"or more survey responses were received.**</i></p></html>"
s = Replace(s, "#NAME#", ws.Cells(i, "C"))
s = Replace(s, "#NPS_YTD#", FormatPercent(ws.Cells(i, "K"), 0))
s = Replace(s, "#RESPONSES#", ws.Cells(i, "H"))
s = Replace(s, "#NPS_ALL#", FormatPercent(ws.Cells(12, "K"), 0))
Dim ff: ff = FreeFile
HTMLFile = Environ$("temp") & "\" & Format(Now(), "~yyyymmddhhmmss") & ".htm"
Open HTMLFile For Output As #ff
Print #ff, s
Close #ff
End Function
Sub Wait(n As Long)
Dim t As Date
t = DateAdd("s", n, Now())
Do While Now() < t
DoEvents
Loop
End Sub