Friday, August 9, 2019

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).




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

Answer



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


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

No comments:

Post a Comment

hard drive - Leaving bad sectors in unformatted partition?

Laptop was acting really weird, and copy and seek times were really slow, so I decided to scan the hard drive surface. I have a couple hundr...