如何使用宏将数据从Excel复制到电子邮件，然后使其成为Outlook窗口中的表

Question

邮件合并的条件是，对于每个电子邮件收件人，我必须以表格格式发送贷方及其关联借方的列表。我有一个标准的电子邮件模板，但是唯一要更改的是每个电子邮件ID的表格（出于机密原因，该表格已模糊）。该模板位于excel的“ Email1”表中。

我有一个像这样的数据集

如您所见，第一列有一个电子邮件ID，该表将进入该ID。还显示了列标题。

我使用excel的语法如下

Sub Macro1()

    Dim nostart1 As Integer, nolenght1 As Integer
    Dim nostart2 As Integer
    Dim OutLookApp As Object
    Dim OutLookMailItem As Object
    Dim lastRow As Long
    Dim i As Long
    Dim wsbody As Range
    Dim entityname As String, agreement As String, bookingentity As String, 
    Account As String

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Workbooks("Something").Sheets("Email1").Activate

    lastRow = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To 3
    Set OutLookApp = CreateObject("Outlook.Application")
    Set OutLookMailItem = OutLookApp.CreateItem(0)
     Windows("Something.xlsm").Activate
    Sheets("Email1").Activate
     Account = Sheets("Data").Range("B" & i) & Sheets("Data").Range("C" & i) &  
    ("Data").Range("D" & i)   'this is where i am trying to call column B, C and 
    D 
    into the email
    Range("B11") = Account  'this is where the table will go into. 

    With OutLookMailItem
     .To = Workbooks("Something").Sheets("Data").Range("A" & i)
    .Subject = "Request for Updated Documentation - ( ASG )"
    .Attachments.Add "W:\something.png"
    .HTMLBody = "<img src='something.png'>" & RangetoHTML(wsbody)
    .CC = "something@something.com"
     .Attachments.Add "W:\something"
     '.send
     .Display

      End With

      Set OutLookMailItem = Nothing
    Set OutLookApp = Nothing

    Next i

       With Application
        .EnableEvents = True
        .ScreenUpdating = True
       End With



     End Sub

    Function RangetoHTML(rng As Range)

    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"


    rng.Copy
    Set TempWB = Workbooks.Add(1)

      With TempWB.Sheets(1)

        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial , , 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


    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

    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=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
  End Function

我在复制常见电子邮件的表格时遇到麻烦，我能做些什么吗？