loop through and copy non empty cell values to email body with each headers

[anish.ms]

Dear Experts,

Request your help with the following

The range "L11:L83" has 8 different headings in column A. How the following code can be modified to capture headings before each set of observations? Also I need to attach a copy of the worksheet to the email

The email body should be like below-

Petty Cash
Observation 1
Observation 10

Revenue Management
Observation 2
Observation 20
Observation 21

and so on...

Thanks in advance for your help

Sub EmailObs()
    Dim wsVR As Worksheet
    Dim obs As Variant
    Dim cell As Range
    Dim xOutlookObj As Object
    Dim xEmailObj As Object


 
    Set wsVR = ThisWorkbook.Worksheets("Visit Checklist")
    
    For Each cell In wsVR.Range("L11:L83")
    If Not IsEmpty(cell) Then
    obs = obs & vbNewLine & cell.Value
    End If
    Next cell
        
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        With xEmailObj
            .Display
            '.To =
            '.CC =
             .Subject = "test"
            .Body = obs
            '.Send
        End With


End Sub