VBA code to send email from Excel

exceluser9

Active Member
Joined
Jun 27, 2015
Messages
370
Hi
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? "
 

Attachments

  • email.JPG
    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.

richh

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

 

Sequoyah

Board Regular
Joined
Mar 26, 2017
Messages
66
Hi exceluser9
try this code:
VBA Code:
Sub Mail()
    'https://www.mrexcel.com/board/threads/vba-to-loop-among-filter-criteria-in-a-specific-column.1019836/post-4894397
    
    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
        Next
        
        '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)
                .Display
                ' .Send
            End With
            
        Next
        'Clear all filters
        
        On Error Resume Next
        .ShowAllData
        On Error GoTo 0
        
    End With
    ActiveWorkbook.Save
    
    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
    MyRange.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
        
        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, _
        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
 

Forum statistics

Threads
1,147,499
Messages
5,741,511
Members
423,663
Latest member
kaveh87rsh

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
Top