将筛选后的表格从电子表格复制/粘贴到电子邮件中

Question

我有有效的 VBA 代码，可以向电子表格上的每个收件人发送电子邮件，并包含电子表格中的文本信息正文。

工作簿包含几个表格，可复制/粘贴到每封电子邮件中。
每个表中的数据需要过滤为适用于每个收件人的数据。

例如：
该电子邮件将发送给区域领导者，其中包含其区域的整体分数。
我有 1 个表格，其中包含可以按地区过滤的经理分数。
在第二个选项卡上，我为每个区域提供了一个表格，可以按服务类型深入了解分数。

因此，对于西南区域领导者，我想过滤表 1 以仅显示西南区域的经理，将该表直接复制/粘贴到电子邮件中，然后转到服务类型表并复制西南表并粘贴到电子邮件。

最后，我想将驻留在单独选项卡上的员工级别详细信息复制到工作簿并将其附加到电子邮件中。这也需要针对每个地区的员工。

以下是电子邮件代码。
我还有根据区域过滤数据的代码。

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

这是“表格”选项卡及其当前的布局方式：

Answer 1

使用

.SpecialCells(xlCellTypeVisible)

设置过滤表上的范围，然后使用

WordEditor

将其复制/粘贴到电子邮件中。要插入 html 文本，请创建一个临时文件并使用

.InsertFile

，这会将 html 格式转换为 word 格式。您可能需要在复制/粘贴操作之间添加等待，具体取决于数据量。

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