Excel VBA宏可向范围内的唯一用户发送电子邮件 [英] Excel VBA macro to send emails to unique users in range
问题描述
我正在尝试创建一个VBA宏,该宏将查找A列,查找所有唯一的电子邮件地址,为每个电子邮件地址创建一个新的Outlook电子邮件,并用该电子邮件所在的行填充该电子邮件的正文(也包括标题).
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).
示例数据:
+----------------+---------------------+---------+
| 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 |
+----------------+---------------------+---------+
推荐答案
我使用了在这里,您会找到如何做
I used the code from my answer mentioned in the comment and modified it. Create a class and name it AppInfo. Here you find how to do that
Option Explicit
Public app As String
Public version As String
然后将以下代码放入模块中.假设是数据位于活动工作表中,起始于A1,标题为Email,Application和Version.
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.
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
这篇关于Excel VBA宏可向范围内的唯一用户发送电子邮件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!