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

Posted 2023-03-27

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

【英文标题】：Automate Email based on details in spreadsheet and copy/paste tables from spreadsheet into corresponding email

【发布时间】：2022-01-10 04:43:09

【问题描述】：

感谢您抽出宝贵时间帮助我完成这个项目。

我有一些 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

【参考方案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 = "pfont:14px Verdana;h1font: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

【讨论】：

CPD1802 - 这真是太棒了！电子邮件看起来比我整理的要好一百万倍！感谢您花时间在这里完全重写我的代码。对于第一个人/地区来说，一切都很好，但是代码停止了，当它试图转移到下一个人时，我得到了一个 Script out of range 错误。这是它停止的地方： 'Service Type Table Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' 表名称与区域 'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address

@JBeets 我假设（可能是错误的！！）每个区域都有一个与该区域同名的表。

我在原始帖子中添加了一张显示表格布局的图片。该选项卡上的每个选项卡都根据区域命名；即 - 西南、东北等。

@JBeets 所有区域表都在同一张纸上吗？第二个人的 A 列中的值是多少？是否有具有该值的表？检查准确的拼写，没有前导或尾随空格。

是的，都在同一张纸上。 A 列是服务代码“Tow、Batter Jump 等”。我可以把它做成任何需要的东西。我试图弄清楚，但你的代码对我来说太聪明了:)