If you find any post useful then, please do share with others. Thanks!

Popular Posts


Email me

Need help and that also free? I like to learn this way, in case of any question or for a small task, please feel free to email me with details and example data, if required.

Wednesday, August 23, 2017

Automatic emails outlook- Excel VBA

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

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("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
     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
               SDest = SDest & ";" & Cells(iCounter, 3).Value
           End If
           End If
       Next iCounter


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)
   fname = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
  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)
      End With
   'End With
   'MsgBox (TimeOfDay)
   Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' 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

    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
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        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, _
        .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
    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. Is there a way to add attachments to the email?

    1. 'Yes please alter the below part of code

      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