如何在 VBA 中从我的文本创建表格

Question

下面的代码从excel文件中提取数据，并通过电子邮件地址合并所有数据，并将数据发送到相应的电子邮件地址。它工作正常，但我希望让数据看起来更好。有没有办法根据以下信息制作表格？

我希望电子邮件具有如下标题：

|_____|_____|_____|_____|
|_____|_____|_____|_____|

我已经看到了 OFT 文件的临时表，但不是直接在 excel 中使用以下代码，但我不确定如何在此代码中执行相同操作：

tmpTbl = tmpTbl & "<tr><td></td><td></td><td align=""center"">*Company</td></tr></table>"

---

Option Explicit

Sub Consolidate()

    #If Early Then
        Dim emailInformation As New Scripting.Dictionary
    #Else
        Dim emailInformation As Object
        Set emailInformation = CreateObject("Scripting.Dictionary")
    #End If

    GetEmailInformation emailInformation
    SendInfoEmail emailInformation

End Sub

Sub GetEmailInformation(emailInformation As Object)

    Dim rg As Range
    Dim sngRow As Range
    Dim emailAddress As String
    Dim myAppInfo As AppInfo
    Dim AppInfos As Collection

    Set rg = Range("A1").CurrentRegion           ' Assuming the list starts in A1 and DOES NOT contain empty row
    Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1) ' Cut the headings

    For Each sngRow In rg.Rows

        emailAddress = sngRow.Cells(1, 1)

        Set myAppInfo = New AppInfo
        With myAppInfo
            .app = sngRow.Cells(1, 2)            'code
            .version = sngRow.Cells(1, 3)        'Company Name
            .ticker = sngRow.Cells(1, 4)         'Abbreviation
            .group = sngRow.Cells(1, 5)          'group sub group
            .lead = sngRow.Cells(1, 6)           'leader
            .banker = sngRow.Cells(1, 7)         'bank
            .analyst = sngRow.Cells(1, 8)        'analyst
            .otw = sngRow.Cells(1, 9)            'at
            .rating = sngRow.Cells(1, 10)        'rank
            .watchlist = sngRow.Cells(1, 11)     'Comments
            .legal = sngRow.Cells(1, 12)         'notes
            .add = sngRow.Cells(1, 13)           'Date
            .last = sngRow.Cells(1, 14)          'Updated
            .id = sngRow.Cells(1, 15)            'ID
        End With

        If emailInformation.Exists(emailAddress) Then
            emailInformation.item(emailAddress).add myAppInfo
        Else
            Set AppInfos = New Collection
            AppInfos.add myAppInfo
            emailInformation.add emailAddress, AppInfos
        End If

    Next

End Sub

Sub SendInfoEmail(emailInformation As Object)

    Dim sBody As String
    Dim sBodyStart As String
    Dim sBodyInfo As String
    Dim sBodyEnd As String
    Dim emailAdress As Variant
    Dim colLines As Collection
    Dim line As Variant

    sBodyStart = "Hi, please find your info below:" & vbCrLf & vbCrLf

    For Each emailAdress In emailInformation
        Set colLines = emailInformation(emailAdress)
        sBodyInfo = ""
        For Each line In colLines
            sBodyInfo = sBodyInfo & _
                        "Code: " & line.app & vbTab & "Company Name:   " & line.app & vbTab & "abbreviation:   " & line.abbreviation & vbTab & "Group Sub Group:   " & line.group & vbTab & "Bank:   " & line.lead & vbTab & "Analyst:   " & line.analyst & vbTab & "at:   " & line.at & vbTab & "Rank:   " & line.rank & vbTab & "Comments:   " & line.comments & vbTab & "Notes:   " & line.notes & vbTab & "Date:   " & line.add & vbTab & "Updated:   " & line.updated & vbTab & "ID:   " & line.id & vbCrLf
        Next
        sBodyEnd = "Best Regards," & vbCrLf & _
                   "Tom"

        sBody = sBodyStart & sBodyInfo & sBodyEnd
        SendEmail emailAdress, "Info", sBody
    Next

End Sub

Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
               , ByVal sBody As String _
                , Optional ByRef coll As Collection)

    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        .VotingOptions = "Accept;Reject"
        .Importance = 2

        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.add item
            Next
        End If

        .Display
        .Send
    End With

    Set outMail = Nothing

End Sub

Answer 1

不要设置纯文本 Body 属性，而是使用表格构造一个有效的 HTML 字符串并将其分配给 HTMLBody 属性。

Answer 2

我没有明显的方法来测试这段代码，所以它可能包含语法错误。我相信我已经包含了足够的解释，以便您在必要时修复代码。如果没有，请发布带有错误的声明，我将诊断原因。

我使用了最简单的 Html。如果您需要更多格式，我可以给您一些建议。

一个 Html 表是：<table> ... <table>

一个 Html 行是：<tr> ... </tr>

一个 Html 单元格是：<td> ... </td>

一个 Html 段落是：<p> ... </p>

初始化sBodyStart 和sBodyEnd：

sBodyStart = "<p>Hi, please find your info below:</p>"
sBodyEnd = "<p>Best Regards,<br>Tom</p>"

添加到您的声明中：

Dim CellValue As Variant

将sbodyInfo = "" 替换为Next 为：

sBodyInfo = "<table>"

sBodyInfo = sBodyInfo & "<tr>"
For Each CellValue in Array("Code", "Company Name", "Abbreviation", _
                            "Group Sub Group", "Bank", "Analyst", _
                            "At","Rank","Comments","Notes","Date", _
                            "Updated","ID")
  sBodyInfo = sBodyInfo & "<td>" & CellValue & "</td>"
Next
sBodyInfo = sBodyInfo & "</tr>"

For Each line In colLines

  sBodyInfo = sBodyInfo & "<tr>"
  For Each CellValue in Array(line.app, line.app, line.abbreviation, _
                              line.group, line.lead, line.analyst, _
                              line.at, line.rank, line.comments, _
                              line.notes, line.add, line.updated, line.id)
    sBodyInfo = sBodyInfo & "<td>" & CellValue & "</td>"
  Next
  sBodyInfo = sBodyInfo & "</tr>"

Next

sBodyInfo = sBodyInfo & "</table>"