Send Email from Excel with Table in Body VBA Macro

				
					Option Explicit



Private Sub Email_in_html_format()

On Error GoTo ErrHandler
    
    ' Set the Outlook object.
    Dim Outlook As Object
    Set Outlook = CreateObject("Outlook.Application")
    
    ' Create email object.
    Dim Email As Object
    Set Email = Outlook.CreateItem(olMailItem)
    
    'We'll now set the range (to extract email id).
    Dim myrange, cell As Range
    Set myrange = Worksheets("sheet1").Range("E1:E10" & Cells(Rows.Count, "B").End(xlUp).Row)
    
    Dim STR As String         ' Variable to store recipients email ids.
    
    ' Run loop to extract email id from the 5th column.
    For Each cell In myrange
        If Trim(cell.Offset(2, 0).Value) <> "" Then
            If Trim(STR) = "" Then
                STR = cell.Offset(2, 0).Value
            Else
                STR = STR & vbCrLf & ";" & cell.Offset(2, 0).Value
            End If
        End If
    Next cell
    
    Set myrange = Nothing     ' Clear the range.
   
    
    '>Now, let's get the columns for the table header.
    Dim ColumnsCount, iColCnt As Integer      ' Column counters.
    Dim aTableHeads As String
    
    ColumnsCount = Worksheets("sheet1").UsedRange.Columns.Count - 1
    
    For iColCnt = 1 To ColumnsCount
        ' Table header concatenated with HTML < th > tags.
        If (aTableHeads) = "" Then
            aTableHeads = "<th>" & Worksheets("sheet1").Cells(1, iColCnt) & "</th>"
        Else
            aTableHeads = aTableHeads & "<th>" & Worksheets("sheet1").Cells(1, iColCnt) & "</th>"
        End If
    Next iColCnt
    ' **
    
    'Finally you get the table data.
    Dim aRowsCount, iRows As Integer          ' Row counters.
    Dim aTableData As String
    aRowsCount = Worksheets("sheet1").UsedRange.Rows.Count
    
    aTableData = "<tr>"       ' HTML <'tr'> tag to create table row.
    For iRows = 3 To aRowsCount
        For iColCnt = 1 To ColumnsCount
            ' Table data concatenated with HTML <td> tags.
            If (aTableData) = "" Then
                aTableData = "<td>" & Worksheets("Sheet1").Cells(iRows, iColCnt) & "</td>"
            Else
                aTableData = aTableData & "<td>" & Worksheets("Sheet1").Cells(iRows, iColCnt) & "</td>"
            End If
        Next iColCnt

        aTableData = aTableData & "</tr>"
    Next iRows
    ' *****
    
    Dim sSubject As String         ' The subject for the email.
    sSubject = Worksheets("sheet1").Cells(1, 1).Value
    
    ' **Add CSS style to the table.
    Dim aTableStyle As String
    aTableStyle = "<style> table.edTable { width: 70%; font: 18px calibri; } table, table.edTable th, table.edTable td { border: solid 1px #494960; border-collapse: collapse; padding: 3px; text-align: center; } table.edTable td { background-color: #5a5f6f; color: #ffffff; font-size: 14px; } table.edTable th { background-color : #494960; color: #ffffff; } tr:hover td { background-color: #494960; color: #dddddd; } </style>"
    
    Dim sHTMLBody As String            ' The body (in HTML format) of the email. The table has a CSS class.
    sHTMLBody = aTableStyle & "<table class='edTable'><tr>" & aTableHeads & "</tr>" & _
            "<tr>" & aTableData & "</tr></table>"
            
    With Email
        ' Assign all email address to the property,In-addition, you can add CC or BCC/.
        .To = STR
        .Subject = sSubject
        .HTMLBody = sHTMLBody
        .Display                   ' Display outlook message window.
        '.Send                     ' Send the email, when you are done i stop it.
    End With
    
    ' Clear all objects.
    Set Email = Nothing:    Set Outlook = Nothing
ErrHandler:
    '
End Sub