根据电子表格中的详细信息自动发送电子邮件，并将表格从电子表格复制/粘贴到相应的电子邮件中

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