How can I send Excel range including header, in table, and email to list?

I have a requirement where I need to send timesheet data for the current week to each person separately in a table using Excel range:

I want to send first row data, including header, into table to joseph then send row data into table to francis.

I have written below code but it sends entire data to each person.

Sub BulkMail()

    Application.ScreenUpdating = False
    ThisWorkbook.Activate
    'Creating references to Application and MailItem Objects of Outlook
    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    'Creating variable to hold values of different items of mail
    Dim sendTo, subj, atchmnt, msg, ccTo, bccTo As String
    Dim lstRow As Long
    'My data is on sheet "Exceltip.com" you can have any sheet name.
     
    ThisWorkbook.Sheets("Sheet1").Activate
    'Getting last row of containing email id in column 3.
    lstRow = Cells(Rows.Count, 3).End(xlUp).Row
    'Variable to hold all email ids
    Dim rng As Range
    Set rng = Range("A1:D" & lstRow)
    Dim rng1 As Range
    Set rng1 = Range("C2:C" & lstRow)
    'initializing outlook object to access its features
    Set outApp = New Outlook.Application
    On Error GoTo cleanup 'to handle any error during creation of object.
    'Loop to iterate through each row, hold data in of email in variables and send
    'mail to each email id.
    For Each cell In rng1
        sendTo = Range(cell.Address).Offset(0, 0).Value2
        On Error Resume Next 'to hand any error during creation of below object
        Set outMail = outApp.CreateItem(0)
        
        'Writing and sending mail in new mail
        With outMail
            .To = sendTo
            .cc = ""
            .HTMLBody = RangetoHTML(rng)
            .Subject = timesheet
            '.Attachments.Add atchmnt
            '.Send 'this send mail without any notification. If you want see mail
            .Display
        End With
        On Error GoTo 0 'To clean any error captured earlier
        Set outMail = Nothing 'nullifying outmail object for next mail
    Next cell 'loop ends
cleanup: 'freeing all objects created
    Set outApp = Nothing
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng 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
    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
    rng.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
    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

I made some modifications: I am trying to handle few errors:

    Sub SendBulkEmailsWithTabularFormatAndHeaders()
    On Error GoTo HandleError

    Dim OutlookApp As Outlook.Application
    Dim OutlookMail As Outlook.MailItem
    Dim ExcelSheet As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim currentEmail As String
    Dim groupedData As String
    Dim emailDict As Object

    Set OutlookApp = New Outlook.Application
    Set ExcelSheet = ThisWorkbook.Worksheets("YourSheetName")

    If ExcelSheet Is Nothing Then
        MsgBox "Sheet 'YourSheetName' not found. Please ensure it's open and has the correct name."
        Exit Sub
    End If

    LastRow = ExcelSheet.Cells(ExcelSheet.Rows.Count, "A").End(xlUp).Row

    Set emailDict = CreateObject("Scripting.Dictionary")

    For i = 2 To LastRow
        currentEmail = ExcelSheet.Cells(i, 1).Value
        If Not emailDict.Exists(currentEmail) Then
            emailDict.Add currentEmail, ""
        End If

        groupedData = groupedData & "<tr><td>" & ExcelSheet.Cells(i, 1).Value & "</td><td>" & ExcelSheet.Cells(i, 2).Value & "</td><td>" & ExcelSheet.Cells(i, 3).Value & "</td><td>" & ExcelSheet.Cells(i, 4).Value & "</td><td>" & ExcelSheet.Cells(i, 5).Value & "</td><td>" & ExcelSheet.Cells(i, 6).Value & "</td><td>" & ExcelSheet.Cells(i, 7).Value & "</td><td>" & ExcelSheet.Cells(i, 8).Value & "</td></tr>"
        emailDict(currentEmail) = emailDict(currentEmail) & groupedData
    Next i

    For Each currentEmail In emailDict.Keys
        Set OutlookMail = OutlookApp.CreateItem(0)
        With OutlookMail
            .To = currentEmail
            .Subject = "Your Subject Line"
            .HTMLBody = "<table><tr><th>Email Address</th><th>Column 2</th><th>Column 3</th><th>Column 4</th><th>Column 5</th><th>Column 6</th><th>Column 7</th><th>Column 8</th></tr>" & emailDict(currentEmail) & "</table>"
            .Send
        End With
    Next currentEmail

    MsgBox "Emails sent successfully."

Exit Sub

HandleError:
    MsgBox "An error occurred while sending emails. Please check your Outlook settings and the data in your Excel sheet."
End Sub