VBA Emailer for an Excel Table

[ishiwhite]

Hello!

Would like to ask if someone can help me create a VBA macro that will email the contents of a table to the recipients.

For example, the table in excel sheet will look like:

Requestor	Email	Issue Title	Issue Number	Status
John Doe	jd@mail.com	wrong name	1231231	Resolved
John Doe	jd@mail.com	wrong address	1231232	Resolved
William Doe	wd@mail.com	wrong name	1231233	Pending

And the email body will be like below:

Hello [Requestor] (in this case, John Doe),

Please see status of your incident requests below:

Requestor	Email	Issue Title	Issue Number	Status
John Doe	jd@mail.com	wrong name	1231231	Resolved
John Doe	jd@mail.com	wrong address	1231232	Resolved

Thank you
--------------

And will email another message but this time for William Doe

Hello [Requestor] (in this case, William Doe),

Please see status of your incident requests below:

Requestor	Email	Issue Title	Issue Number	Status
William Doe	wd@mail.com	wrong name	1231233	Pending

Thank you
--------------


The table can contain as much as 50 records and should be able to send all the emails to the intended recipients.


Thank you in advance!

 

[Keetoowah]

Hi ishiwhite
try the following code, adapted from my previous answer, to adapt the sheet name and the email subject:

Sub mailishiwhite()
'https://chandoo.org/forum/threads/vba-emailer-for-an-excel-table.57659/
    Dim Wks         As Worksheet
    Dim OutMail     As Object, OutApp As Object
    Dim cel         As Range, myRng As Range
    Dim Itm         As Variant
    Dim LastRow     As Long
    Dim Dest        As String, strbody As String, Requestor As String

    Dim collOwner   As New Collection
    
    Set Wks = ThisWorkbook.Sheets("Sheet1") '<<============ ADAPT Sheet name
    
    On Error Resume Next
    For Each cel In Wks.Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
        collOwner.Add cel.Value, CStr(cel.Value)
    Next
    On Error GoTo 0
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    For Each Itm In collOwner
        
        Wks.Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row).AutoFilter Field:=2, Criteria1:=Itm
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        On Error Resume Next
        
        LastRow = Cells(Rows.Count, "A").End(xlUp).Row
        Set myRng = Wks.Range("A1:E" & LastRow).SpecialCells(xlCellTypeVisible)
        
        Dest = Cells(LastRow, "B").Value
        Requestor = Cells(LastRow, "A").Value
        
        strbody = "Dear " & Requestor & "<br>" & _
                  "Please see status of your incident requests below:" & "<br/><br>"
        
        With OutMail
            .to = Dest
            .CC = ""
            .BCC = ""
            .Subject = "Adapt the subject" '<<====== ADAPT the subject
            .HTMLBody = strbody & ConvertRangeToHTMLTable(myRng) & "<br>" & "Thank you" & "<br>" & "--------------"

            .Display
            '.Send
        End With
        On Error GoTo 0
    Next
    
    On Error Resume Next
    Wks.ShowAllData
    On Error GoTo 0
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub
'Following function converts Excel range to HTML table
Public Function ConvertRangeToHTMLTable(rInput As Range) As String
'https://www.excelsirji.com/vba-code-to-convert-excel-range-into-html-table/

    'Declare variables
    Dim rRow As Range
    Dim rCell As Range
    Dim strReturn As String
    'Define table format and font
    strReturn = "<Table border='1' cellspacing='0' cellpadding='7' style='border-collapse:collapse;border:none'>  "
    'Loop through each row in the range
    For Each rRow In rInput.Rows
        'Start new html row
        strReturn = strReturn & " <tr align='Center'; style='height:10.00pt'> "
        For Each rCell In rRow.Cells
            'If it is row 1 then it is header row that need to be bold
            If rCell.Row = 1 Then
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'><b>" & rCell.Text & "</b></td>"
            Else
                strReturn = strReturn & "<td valign='Center' style='border:solid windowtext 1.0pt; padding:0cm 5.4pt 0cm 5.4pt;height:1.05pt'>" & rCell.Text & "</td>"
            End If
        Next rCell
        'End a row
        strReturn = strReturn & "</tr>"
    Next rRow
    'Close the font tag
    strReturn = strReturn & "</font></table>"
    'Return html format
    ConvertRangeToHTMLTable = strReturn
End Function

 

[ishiwhite]

Thank you for this! This really a great help!