VBA code to send email from Excel


Active Member
Jun 27, 2015
I wanted VBA code to send emails at the click of the button based on the information we have on the excel sheet.

from column A to K we have data

Column A to K is data and on Column J & K has got the email ID Column J will be To and K will be CC

the VBA code has to pick data from the excel sheet copy data from column A to K as per the email id if the same ID has 2 records it has pick 2 records and paste in the body of example Arun@gmail.com as 2 records and vickey@gmail.com has got 2 records so one email each with these 2 records.

referenceValueDesstatusSup numSup naactivity_start_weekactivity_end_weekactivity end dateEmail Id (TO)Email Id (CC)
2105029R3ZRE2Q3030water billpending2234Aarooa20211920212201-08-2021Arun@gmail.comgopi@gmail.com
220220361NIP67F1200Electrical billpending2234Aarooa20211920212201-08-2021Arun@gmail.comgopi@gmail.com

and the body of email it should say " As the activity of the below deal is completed, can you please approve it as early as possible? "


  • email.JPG
    106.7 KB · Views: 3

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.


Board Regular
Jun 24, 2007
Office Version
  1. 365
  2. 2016
Here's a great article about how to create emails from Excel/VBA



Board Regular
Mar 26, 2017
Hi exceluser9
try this code:
VBA Code:
Sub Mail()
    Dim SupNameDict As Object, SupNames As Variant, i As Long, SupName As Variant
    Dim OutlookApp As Object, MItem As Object, Dest As String, DestCC As String
    Dim Sh As Worksheet
    Dim MyRange As Range, LastRow As Long
    Set SupNameDict = CreateObject("Scripting.Dictionary")
    Set Sh = ThisWorkbook.ActiveSheet
    Application.ScreenUpdating = False
    'The code looks at data on the active sheet
    With Sh
        'Show AutoFilter if not already and all rows
        If Not .AutoFilterMode Then .UsedRange.AutoFilter
        'Create list of unique SupNames in column F
        SupNames = Range(.Range("F2"), .Cells(Rows.Count, "F").End(xlUp))
        For i = 1 To UBound(SupNames, 1)
            SupNameDict(SupNames(i, 1)) = 1
        'For each unique SupName
        For Each SupName In SupNameDict.keys
            'AutoFilter on column F with this SupName
            .UsedRange.AutoFilter Field:=6, Criteria1:=SupName
            LastRow = .Range("A" & Rows.Count).End(xlUp).Row
            Dest = Columns(10).Cells.SpecialCells(xlCellTypeVisible).Cells(LastRow).Value
            DestCC = Columns(11).Cells.SpecialCells(xlCellTypeVisible).Cells(LastRow).Value
            Set MyRange = Sh.Range("A1:I" & LastRow)
            Set OutlookApp = CreateObject("Outlook.Application")
            Set MItem = OutlookApp.CreateItem(0)
            With MItem
                .To = Dest
                .cc = DestCC
                .Subject = "my Subject - To be adapted!"
                .htmlBody = " As the activity of the below deal Is completed, can you please approve it As early As possible? " & "<br>" & RangetoHTML(MyRange)
                ' .Send
            End With
        'Clear all filters
        On Error Resume Next
        On Error GoTo 0
    End With
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Function RangetoHTML(MyRange 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
    Dim j As Integer
    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
        For j = 7 To 12
            With .UsedRange.Borders(j)
                .LineStyle = xlContinuous
                .ColorIndex = xlAutomatic
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        Next j
    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

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back