我正在尝试创建一个VBA宏，该宏将查找A列，查找所有唯一的电子邮件地址，为每个电子邮件地址创建一个新的Outlook电子邮件，并用该电子邮件所在的行填充该电子邮件的正文（也包括标题）。
示例数据：
+----------------+---------------------+---------+
| Email | Application | Version |
+----------------+---------------------+---------+
| test1@test.com | Microsoft_Office_13 | v2.0 |
| test1@test.com | Putty | v3.0 |
| test1@test.com | Notepad | v5.6 |
| test2@test.com | Microsoft_Office_13 | v2.0 |
| test2@test.com | Putty | v3.0 |
| test2@test.com | Adobe_Reader | v6.4 |
| test3@test.com | Microsoft_Office_13 | v3.6 |
| test3@test.com | Paint | v6.4 |
| test3@test.com | Adobe_Reader | v6.4 |
+----------------+---------------------+---------+
这是我能够在研究中找到的内容，但是每次列出地址时都会创建一封电子邮件。它也实际上没有任何代码可以显示如何将一系列细胞引入体内。
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
.Body = "Hi, please find your account permissions below:"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
所需的电子邮件输出将类似于：
您好，请在下面找到您的帐户权限：
+----------------+---------------------+---------+
| Email | Application | Version |
+----------------+---------------------+---------+
| test2@test.com | Microsoft_Office_13 | v2.0 |
| test2@test.com | Putty | v3.0 |
| test2@test.com | Adobe_Reader | v6.4 |
+----------------+---------------------+---------+
答案 0 :(得分：0)
您可以通过不同的方式来执行此操作，但是我只是给您一个快速的答案，可以解决您的问题。我使用了罗恩·德布鲁因（Ron de Bruin）开发的函数，将范围转换为html正文。
我删除了检查A列中单元格内容的条件之一，因此请确保将其放回并用自己的数据进行测试
我使用词典来存储我们生成的Outlook实例的电子邮件，因此，如果在其他单元格中您具有相同的电子邮件，则不会再次生成电子邮件
您需要在Outlook新项目中使用html正文而不是body，以便您有更多选择来快速粘贴内容并设置其格式（颜色，大小，字体等）
Option Explicit
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim dict As Object 'keep the unique list of emails
Dim cell As Range
Dim cell2 As Range
Dim rng As Range
Dim i As Long
Dim WS As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set dict = CreateObject("scripting.dictionary")
Set WS = ThisWorkbook.Sheets("Sheet1") 'change the name of the sheet accordingly
On Error GoTo cleanup
For Each cell In WS.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
'check if this email address has been used to generate an outlook email or not
If dict.exists(cell.Value) = False Then
dict.Add cell.Value, "" 'add the new email address
Set OutMail = OutApp.CreateItem(0)
Set rng = WS.UsedRange.Rows(1)
'find all of the rows with the same email and add it to the range
For Each cell2 In WS.UsedRange.Columns(1).Cells
If cell2.Value = cell.Value Then
Set rng = Application.Union(rng, WS.UsedRange.Rows(cell2.Row))
End If
Next cell2
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
.HTMLBody = "Hi, please find your account permissions below:" & vbNewLine & vbNewLine & RangetoHTML(rng)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range)
' coded 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
答案 1 :(得分：0)
我使用了注释中提到的answer中的代码，并对其进行了修改。 创建一个类，并将其命名为AppInfo。 Here您将找到如何做
Option Explicit
Public app As String
Public version As String
然后将以下代码放入模块。假设数据位于活动工作表中，起始于A1，标题为Email，Application和Version。
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)
.version = sngRow.Cells(1, 3)
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 account permissions below:" & vbCrLf
For Each emailAdress In emailInformation
Set colLines = emailInformation(emailAdress)
sBodyInfo = ""
For Each line In colLines
sBodyInfo = sBodyInfo & _
"Application: " & line.app & vbTab & "Version:" & line.version & vbCrLf
Next
sBodyEnd = "Best Regards" & vbCrLf & _
"Team"
sBody = sBodyStart & sBodyInfo & sBodyEnd
SendEmail emailAdress, "Permissions", 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
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
答案 2 :(得分：0)
我认为，最简单的方法是将表格式化为Excel中的表格式（这将启用搜索和排序功能）。然后您可以执行类似
的操作DSET ^AHI8_L2MOA.I2016001.000000.v210.bin
TITLE AHI8_L2MOA.I2016001.000000.v210.bin
*OPTIONS yrev little_endian
UNDEF -999999.0
XDEF 3425 linear 1 1
YDEF 1721 linear 1 1
ZDEF 10 linear 1 1
TDEF 1 linear 00:00Z01JAN2016 10mn
VARS 11
mlon 0 99 Longitude (deg)
mlat 0 99 Latitude (deg)
qflg 0 99 QA flag
mtim 0 99 Measurement time (hours)
snza 0 99 Sensor zenith angle (deg)
snaa 0 99 Sensor azimuth angle (deg)
soza 0 99 Solar zenith angle (deg)
soaa 0 99 Solar azimuth angle (deg)
selv 0 99 Surface elevation (m)
rada 6 99 Albedo (%), 1,2,3,4,5,6
如果执行通过检查（data.Rows.Count> 0），则可以使用HTML发送邮件：
email = "test1@test.com"
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set tbl = ws.ListObjects("Table1")
tbl.Range.AutoFilter Field:=1, Criteria1:=email
Set data = tbl.DataBodyRange
If (data.Rows.Count = 0) Then Exit Sub
，它需要以下辅助功能：
Set app = CreateObject("Outlook.Application")
Set mail = OutApp.CreateItem(0)
bodyText = "<BODY style=font-size:11pt;font-family:Calibri>" & _
" Hi, please find your account permissions below: <br> </BODY> "
With mail
.To = email
.Subject = "Email title here."
.HTMLBody = bodyText & "<p>" & RangeToHTML(data)
.Importance = 1 ' normal
.Display
End With
您可以根据需要进行修改。