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("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

  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)

   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

Pull Unique Values with Advanced Filter

Pull Unique Values with Advanced Filter

 

Though there are many ways of removing duplicates, I just wanted to share a use of Advanced filter for same.

We can use advanced filter to pull non duplicate items from a column(s).

For this go to Data tab and then click on Advanced.

A dialog box will open. Here choose the option of Copy to another location. In list Range box, mention the range from which we want to extract unique values. And in Copy to box, the place where we want our unique list to appear.

Then check the box of unique records only. Now click on ok.

And we have now two lists the original along new one having just unique items.

Note: There is no link between original data and filtered data so in case original data changes, the advanced filter must be run again.

Using What-If Analysis – Goal Seek- for finding a result by adjusting input

Using What-If Analysis – Goal Seek- for finding a result by adjusting input

In case we are aware of the result from a formula but don’t know the input value that formula needs for that result, we can use the Goal seek feature.

Please note this will work with one variable input value only.

Example to understand Goal Seek.

We want to have an Average of 15 in cell B7. The current Average of 5 values is 14.2. With our 6^th value in B6, we want the Average as 15 but don’t know the input value in B6. The output or Average returning cell B7 have formula of Average and range include the blank or input cell B6.

So let’s use the Goal Seek. Go to Data tab, and under What-If Analysis click on option of Goal Seek.

 

A window will open. So in first option ‘Set Cell’ we will mention the cell where we want our output, in our case it is B7 where we want our Average as 15. And To Value is 15, so by changing Cell B6, the input value, we want Value 15 in Cell B7.

Now press ok, excel will calculate the value and return, pressing ok will populate it in sheet.

So we can see it is 19. 

Value 1	17
Value 2	15
Value 3	14
Value 4	13
Value 5	12
Value 6	19
Average	15

 

Extracting Date from a Date Time - in Excel

Us the INT function to extract Date from Date-Time field

Sometimes we might want to fetch just the date from a Date time field, for better use i.e. sorting or grouping or filter in Pivot. As Date time could be messy.

As we know the Dates, Times and Date-Times are serial numbers in Excel. We normally don’t see the underlying numbers.

We can see the underlying number by formatting the cell to General.

 

So here the integer portion is the date serial number and the fractional part is the time serial number. 

So the INT function will help us in fetching the date part from a Date-Time value. The cell where INT function is used, the formatting of cell be Date to show just the Date.

 

 

Autocomplete when typing in Excel drop down list

How to autocomplete when typing in Excel drop down list?

ActiveX Controls Combo Box VBA

Click here to read the article that I found online