我如何发送 Excel 范围包括 header，在 table 中，并通过电子邮件发送到列表？

Question

我有一个要求，我需要使用 Excel 范围 table 将本周的时间表数据分别发送给每个人：

我想将第一行数据（包括 header）发送到 table 给约瑟夫然后将行数据发送到 table 给 francis.

我写了下面的代码，但它向每个人发送了完整的数据。

Sub BulkMail()

    Application.ScreenUpdating = False
    ThisWorkbook.Activate
    'Creating references to Application and MailItem Objects of Outlook
    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    'Creating variable to hold values of different items of mail
    Dim sendTo, subj, atchmnt, msg, ccTo, bccTo As String
    Dim lstRow As Long
    'My data is on sheet "Exceltip.com" you can have any sheet name.
     
    ThisWorkbook.Sheets("Sheet1").Activate
    'Getting last row of containing email id in column 3.
    lstRow = Cells(Rows.Count, 3).End(xlUp).Row
    'Variable to hold all email ids
    Dim rng As Range
    Set rng = Range("A1:D" & lstRow)
    Dim rng1 As Range
    Set rng1 = Range("C2:C" & lstRow)
    'initializing outlook object to access its features
    Set outApp = New Outlook.Application
    On Error GoTo cleanup 'to handle any error during creation of object.
    'Loop to iterate through each row, hold data in of email in variables and send
    'mail to each email id.
    For Each cell In rng1
        sendTo = Range(cell.Address).Offset(0, 0).Value2
        On Error Resume Next 'to hand any error during creation of below object
        Set outMail = outApp.CreateItem(0)
        
        'Writing and sending mail in new mail
        With outMail
            .To = sendTo
            .cc = ""
            .HTMLBody = RangetoHTML(rng)
            .Subject = timesheet
            '.Attachments.Add atchmnt
            '.Send 'this send mail without any notification. If you want see mail
            .Display
        End With
        On Error GoTo 0 'To clean any error captured earlier
        Set outMail = Nothing 'nullifying outmail object for next mail
    Next cell 'loop ends
cleanup: 'freeing all objects created
    Set outApp = Nothing
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
      SourceType:=xlSourceRange, _
      Filename:=TempFile, _
      Sheet:=TempWB.Sheets(1).Name, _
      Source:=TempWB.Sheets(1).UsedRange.Address, _
      HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Answer 1

可以使用Application.Intersect(rng, Cell.EntireRow)获取当前行的部分数据。 Union() 在将 header 行推入 RangetoHTML() 函数之前。

.HTMLBody = RangetoHTML(Union(rng.Rows(1), Application.Intersect(rng, Cell.EntireRow)))

我如何发送 Excel 范围包括 header，在 table 中，并通过电子邮件发送到列表？

How can I send Excel range including header, in table, and email to list?

excel

outlook

vba