[英]Excel VBA macro to send emails to unique users in range
I'm trying to create a VBA macro that will look into the A column, find all unique email addresses, create a new outlook email for each and populate the body of that email with the rows where that email is present (also including the header).我正在尝试创建一个 VBA 宏,它将查看 A 列,查找所有唯一的电子邮件地址,为每个电子邮件地址创建一个新的 Outlook 电子邮件,并使用该电子邮件所在的行(还包括标题)填充该电子邮件的正文)。
Example data:示例数据:
+----------------+---------------------+---------+
| 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 |
+----------------+---------------------+---------+
This is what I was able to find in my research, but it will create an email for every time the address is listed.这是我在研究中能够找到的,但是每次列出地址时它都会创建一封电子邮件。 It also doesn't really have any code which shows how to pull a range of cells into the body.它也没有任何代码显示如何将一系列细胞拉入体内。
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
The desired email output would be something like:所需的电子邮件输出类似于:
Hi, please find your account permissions below:您好,请在下面找到您的帐户权限:
+----------------+---------------------+---------+
| Email | Application | Version |
+----------------+---------------------+---------+
| test2@test.com | Microsoft_Office_13 | v2.0 |
| test2@test.com | Putty | v3.0 |
| test2@test.com | Adobe_Reader | v6.4 |
+----------------+---------------------+---------+
You can do this in different ways, but I am just giving you a quick answer that will solve your problem.你可以用不同的方式来做到这一点,但我只是给你一个快速的答案来解决你的问题。 I used a function developed by Ron de Bruin to convert the range to an html body.我使用 Ron de Bruin 开发的函数将范围转换为 html 正文。
I deleted one of the conditions to check the content of the cells in column A so make sure you put it back and test it with your own data我删除了检查 A 列中单元格内容的条件之一,因此请确保将其放回原处并使用您自己的数据进行测试
I used a dictionary to store the emails we generate the outlook instance so if in the other cells you have the same email you would not generate the email again我使用字典来存储我们生成 Outlook 实例的电子邮件,因此如果在其他单元格中您有相同的电子邮件,则不会再次生成电子邮件
you need to use an html body instead of body in the outlook new item so that you have more options to quickly paste your content and format it (color, size, font etc)您需要在 Outlook 新项目中使用 html 正文而不是正文,以便您有更多选择来快速粘贴您的内容并对其进行格式化(颜色、大小、字体等)
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
I used the code from my answer mentioned in the comment and modified it.我使用了评论中提到的答案中的代码并对其进行了修改。 Create a class and name it AppInfo.创建一个类并将其命名为 AppInfo。 Here you find how to do that 在这里你可以找到如何做到这一点
Option Explicit
Public app As String
Public version As String
Then put the following code into a module.然后把下面的代码放到一个模块中。 The asumption is that the data is in the active sheet starting in A1 with the header Email, Application and Version.假设数据位于以 A1 开头的活动工作表中,标题为电子邮件、应用程序和版本。
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
Simplest way, in my opinion, would be to format your table as a table in Excel (which will enable search and sort).在我看来,最简单的方法是将您的表格格式化为 Excel 中的表格(这将启用搜索和排序)。 Then you could do something like eg然后你可以做类似的事情
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
If execution makes it past the check (data.Rows.Count > 0) then you can send a mailer using HTML:如果执行通过检查 (data.Rows.Count > 0),那么您可以使用 HTML 发送邮件:
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
which requires the following helper function:这需要以下辅助函数:
Function RangeToHTML(rng As Range) As String
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.Offset(1).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=")
tempWB.Close savechanges:=False
Kill tempFile
Set ts = Nothing
Set fso = Nothing
Set tempWB = Nothing
End Function
You can modify as needed.您可以根据需要进行修改。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.