Outlook Application with HTMLBody

Option Explicit
Dim outApp As Outlook.Application, oMailItem As Outlook.MailItem, strBody As String
Dim rowcount As Long, statusrng As Range, cell, heading As String
Sub sendstatuswiseMails()
    Set outApp = New Outlook.Application
 
    rowcount = ThisWorkbook.Sheets(1).Range("G1").End(xlDown).Row
    Set statusrng = ThisWorkbook.Sheets(1).Range("G2:G" & rowcount)
    heading = "<table border=" & """1""" & ",collapsing=1><tr><td>" & Range("A1") & "</td><td> " & Range("B1") & "</td><td> " & Range("C1") & "</td><td> " & Range("D1") & "</td><td width=20> " & Range("E1") & "</td><td width=20> " & Range("F1") & "</td><td> " & Range("H1") & "</td></tr>"
    For Each cell In statusrng
        strBody = vbNullString
        If cell.Value = "True" Then
        Set oMailItem = outApp.CreateItem(olMailItem)
            With oMailItem
                .To = cell.Offset(0, 2)
                strBody = strBody & "Hi," & "<br>"
                strBody = strBody & vbTab & vbTab & vbTab & "<p>Please find the status below</p>" & vbNewLine & vbNewLine
             
                strBody = strBody & heading
                strBody = strBody & "<tr><td>" & cell.Offset(0, -6) & "</td><td>" & cell.Offset(0, -5) & "</td><td>" & cell.Offset(0, -4) & "</td><td>" & cell.Offset(0, -3) & "</td><td>" & cell.Offset(0, -2) & "</td><td>" & cell.Offset(0, -1) & "</td><td>" & cell.Offset(0, 1) & "</td></tr></table>"
                strBody = strBody & "<br><p>Regards,<br>Soumyendu"
                .Subject = "Update for " & cell.Offset(0, -5)
                .HTMLBody = strBody
             
                .Display
                Application.Wait (Now + TimeValue("00:00:03"))
                Application.SendKeys "%s"
            End With
        Set oMailItem = Nothing
        End If
    Next
 
End Sub

File to download