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

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

2 个答案: