VBA code to send email from Excel

[exceluser9]

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.

reference	Value	Des	status	Sup num	Sup na	activity_start_week	activity_end_week	activity end date	Email Id (TO)	Email Id (CC)
2105029R3ZRE2Q	3030	water bill	pending	2234	Aarooa	202119	202122	01-08-2021	Arun@gmail.com	gopi@gmail.com
220220361NIP67F	1200	Electrical bill	pending	2234	Aarooa	202119	202122	01-08-2021	Arun@gmail.com	gopi@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? "

 

[richh]

Here's a great article about how to create emails from Excel/VBA

VBA Send Email from Excel

VBA Code to Send Emails From Excel In VBA, to send emails from Excel, we can automatically automate our mailing feature to send emails to multiple users

www.wallstreetmojo.com

 

[Sequoyah]

Hi exceluser9
try this 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

 

[tarunhshah]

Hi exceluser9
try this 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

hi, all datas in excel are going to email ID mentioned on the last row of data sheet, thankful if you can amend the code to send each row with header in Email ID mentioned in column J &K ?