Automatic emails
outlook- Excel VBA
In this post, I want to share a VBA code/Macro that first
formats data in Excel sheet, saves it with today’s date and composes the Email
in outlook, adds attachment and body so before it is sent, you take a quick glance
and then press the send button.
The
example file can be downloaded.
VBA code is saved in this file (Module 1) and can be run manually by clicking on Developer tab > VBA > Module 1 and run button (used to run code).
VBA code is saved in this file (Module 1) and can be run manually by clicking on Developer tab > VBA > Module 1 and run button (used to run code).
So we have a file with three sheets, the first one namely ‘Summary’
have a pivot summarizing data that we want to include in our email body.
In second sheet, we have raw data that is the basis of our
summary pivot. From here we will compile the email list to whom we want to send email.
In sheet3, the email list compilation will work behind the
scenes with VBA.
So our VBA code, mentioned below, will do following.
> First it will go to Sheet3 and clear contents from A,B and C Column
if any.
> Copy the email addresses from columns E & G of Sheet
Summary, combines them, removes duplicates and save them in Column C of Sheet 3.
> Arranges EMAIL addresses in order i.e. separated by “;”, and
then clears the contents of Sheet3’s column C.
> Saves the File at specified location and name with current
date. Note: In this part of code, you need to update the file location and name
as per your requirement.
> Now the Summary sheet’s data will be copied in EMAIL body
and TO and CC email addresses, and file attachment, will be added. Note: Here
you need to change the CC email address as per need or remove the CC line.
VBA Code
Sub Send_Range()
Sheets("sheet3").Columns("A").ClearContents
Sheets("sheet3").Columns("B").ClearContents
Sheets("sheet3").Columns("C").ClearContents
Sheets("Raw").Columns("E").AdvancedFilter
Action:=xlFilterCopy,
CopyToRange:=Sheets("sheet3").Columns("A"), Unique:=True
Sheets("Raw").Columns("G").AdvancedFilter
Action:=xlFilterCopy,
CopyToRange:=Sheets("sheet3").Columns("B"), Unique:=True
Dim oneColumnHead As Range
Dim columnHeads As Range
With ThisWorkbook.Sheets("sheet3")
Set columnHeads =
Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))
End With
For Each oneColumnHead In columnHeads
With
oneColumnHead.EntireColumn
With Range(.Cells(2,
1), .Cells(.Rows.Count, 1).End(xlUp))
.Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).Offset(1,
0).Resize(.Rows.Count, 1).Value = .Value
End With
End With
Next oneColumnHead
Sheets("Sheet3").Columns("A").AdvancedFilter
Action:=xlFilterCopy,
CopyToRange:=Sheets("sheet3").Columns("C"), Unique:=True
Sheets("sheet3").Columns("A").ClearContents
Sheets("sheet3").Columns("B").ClearContents
ThisWorkbook.Worksheets("Sheet3").Select
SDest =
""
For iCounter =
2 To WorksheetFunction.CountA(Columns(3)) + 200
If
(Cells(iCounter, 3).Value <> "" And Cells(iCounter, 3).Value
<> "NULL") Then
If SDest =
"" Then
SDest =
Cells(iCounter, 3).Value
Else
SDest = SDest & ";"
& Cells(iCounter, 3).Value
End If
End If
Next iCounter
Sheets("sheet3").Columns("C").ClearContents
ActiveWorkbook.SaveAs
Filename:="C:\Users\amiqullahkhan\Desktop\SalesAudit " &
Format(Now(), "DD-MMM-YYYY") & ".xlsm", FileFormat:=52
'Update the File address and name as per your need
Dim OutApp As
Object
Dim OutMail As
Object
Set OutApp =
CreateObject("Outlook.Application")
Set OutMail =
OutApp.CreateItem(0)
ThisWorkbook.Activate
fname =
ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
Worksheets("Summary").Activate
Dim num As Integer
Dim Copyrange
Dim rng As Range
Dim num As Integer
Dim Copyrange
Dim rng As Range
num =
WorksheetFunction.CountA(Columns(1))
Let Copyrange =
"A" & 1 & ":" & "C" & num
Set rng = Sheets("Summary").Range("A"
& 1 & ":" & "C" &
num).SpecialCells(xlCellTypeVisible)
With OutMail
'Debug.Print
SDest
'With .Item
.To = SDest
.CC =
"Amiq Ullah <Amiqullah@gmail.com>"
.Subject =
"Sales Compliance Audit"
.Attachments.Add fname
.HTMLBody =
RangetoHTML(rng)
.DISPLAY
End With
'End With
'MsgBox (TimeOfDay)
'MsgBox (TimeOfDay)
Set OutMail =
Nothing
Set OutApp =
Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed 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
Below almost same code, which do a different set of formatting, like deleting rows given a condition met and then deleting columns, copying data etc.
Sub Amiq()
Sheets("Email").Cells.ClearContents
Sheets("Summary").Range("A1:J122").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Email").Range("A1:J122"), Unique:=True
Sheets("Email").Select
Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, 9) = 0 Then
Rows(r).Delete
End If
Next r
Columns("C:H").EntireColumn.Delete
SDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(4))
If (Cells(iCounter, 4).Value <> "" And Cells(iCounter, 4).Value <> "NULL") Then
If SDest = "" Then
SDest = Cells(iCounter, 4).Value
Else
SDest = SDest & ";" & Cells(iCounter, 4).Value
End If
End If
Next iCounter
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
ThisWorkbook.Activate
Worksheets("Email").Activate
Dim num As Integer
Dim Copyrange
Dim rng As Range
num = WorksheetFunction.CountA(Columns(1))
Let Copyrange = "A" & 1 & ":" & "C" & num
Set rng = Sheets("Email").Range("A" & 1 & ":" & "C" & num).SpecialCells(xlCellTypeVisible)
ActiveWorkbook.SaveAs Filename:="C:\Users\amiqullahkhan\Desktop\UnApprovedSheet " & Format(Now(), "DD-MMM-YYYY") & ".xlsm", FileFormat:=52
fname = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OutMail
'Debug.Print SDest
'With .Item
.To = SDest
.CC = "Wajeeha.Nisar@spglobal.com"
.Subject = "Urgent: Please approve your Un-Approved Data"
.Attachments.Add fname
.HTMLBody = RangetoHTML(rng)
.Display
End With
'End With
'MsgBox (TimeOfDay)
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
' Changed 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
Below almost same code, which do a different set of formatting, like deleting rows given a condition met and then deleting columns, copying data etc.
Sub Amiq()
Sheets("Email").Cells.ClearContents
Sheets("Summary").Range("A1:J122").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Email").Range("A1:J122"), Unique:=True
Sheets("Email").Select
Dim r As Long
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For r = LastRow To 1 Step -1
If Cells(r, 9) = 0 Then
Rows(r).Delete
End If
Next r
Columns("C:H").EntireColumn.Delete
SDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(4))
If (Cells(iCounter, 4).Value <> "" And Cells(iCounter, 4).Value <> "NULL") Then
If SDest = "" Then
SDest = Cells(iCounter, 4).Value
Else
SDest = SDest & ";" & Cells(iCounter, 4).Value
End If
End If
Next iCounter
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
ThisWorkbook.Activate
Worksheets("Email").Activate
Dim num As Integer
Dim Copyrange
Dim rng As Range
num = WorksheetFunction.CountA(Columns(1))
Let Copyrange = "A" & 1 & ":" & "C" & num
Set rng = Sheets("Email").Range("A" & 1 & ":" & "C" & num).SpecialCells(xlCellTypeVisible)
ActiveWorkbook.SaveAs Filename:="C:\Users\amiqullahkhan\Desktop\UnApprovedSheet " & Format(Now(), "DD-MMM-YYYY") & ".xlsm", FileFormat:=52
fname = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With OutMail
'Debug.Print SDest
'With .Item
.To = SDest
.CC = "Wajeeha.Nisar@spglobal.com"
.Subject = "Urgent: Please approve your Un-Approved Data"
.Attachments.Add fname
.HTMLBody = RangetoHTML(rng)
.Display
End With
'End With
'MsgBox (TimeOfDay)
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
