以下代码从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