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

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

Code:

---

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

---

This is the best I managed to do. I'm taking advantage of the fact that you merged the cells for your headers.
By the way, I have no idea how to format headers bold unless you use HTML to create the body of your email.

Code:

---

'...
For Each cell In wsVR.Range("L11:L83")
    If Not IsEmpty(cell) Then
        If cell.Offset(0, -11).Value <> "" Then obs = obs & vbNewLine & vbNewLine & cell.Offset(0, -11) '<- added
        obs = obs & vbNewLine & cell.Value
    End If
Next cell
'...

---

*** Sorry, I just found a bug, my edit only works if in column L the section has an observation in the first row (as per your example), elsewise, it will not add the header to obs.

Thanks for your time and help rollis,

Yes, it is not picking the first heading in case cell L11 is blank.
I need to find a way to covert the email body to HTML and I also need to copy the range P11:X24 as an image to the email body + attach a copy of the worksheet "Visit Checklist" as mentioned previously.

This is what I came up with as per headers in obs. Did some testing, seems okay : pray2:.

Code:

---

'...
obs = "Dear " & wsVR.Range("G6").Value & "," & vbNewLine & _
      "We have conducted a detailed LP review of " & wsVR.Range("D4").Value & " Store (" & wsVR.Range("D5").Value & ") " & _
      "as on " & Format(wsVR.Range("D7").Value, "DD-MMM-YYYY") & ". " & "Based on the observations, the store is categorized as " & SRating & "." & vbNewLine & _
      "Please find the summary below and request your action plans and corrective measures within three working days." & vbNewLine & _
      "Important Observations noted are as follows-"
Dim flag  As Boolean                        '<- added
Dim head  As String                          '<- added
For Each cell In wsVR.Range("L11:L83")
    If Not IsEmpty(cell) Then
        '----- added ----------------------------------------------------------
        If head <> cell.Offset(0, -11).MergeArea.Cells(1, 1) Then flag = False 'detect if header has changed (new section) then reset flag
        If flag = False Then                  'detect if header has already been added to obs
            obs = obs & vbNewLine & vbNewLine & cell.Offset(0, -11).MergeArea.Cells(1, 1) & ":" 'add header to obs
            head = cell.Offset(0, -11).MergeArea.Cells(1, 1) 'store header
            flag = True                      'set flag for header already added to obs
        End If
        '----- added ----------------------------------------------------------
        obs = obs & vbNewLine & cell.Value
    End If
Next cell
'...

---

If you still need to use Bold font in the body I suggest Ron De Bruin's site LINK

Thanks rollis

Thanks for the feedback, glad having been of some help.

I managed to create the codes. Thanks again rollis for the link which was very helpful to prepare the codes

Code:

---

Sub DraftEmail()


    Dim wsVR  As Worksheet
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim wbVR  As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrBody As String
    Dim Obs    As String
    Dim Cell  As Range
    Dim SRating As String
    Dim MakeJPG As String


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
   
   
    Set wbVR = ThisWorkbook
    Set wsVR = wbVR.Worksheets("Visit Checklist")
    wsVR.Copy
    Set Destwb = ActiveWorkbook
   
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            FileExtStr = ".xlsx": FileFormatNum = 51
        End If
    End With
   
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Visit Checklist - store " & wsVR.Range("D5").Value
   
    Select Case wsVR.Range("X20").Value
        Case Is < 0.7
            SRating = "Red"
        Case Is > 0.85
            SRating = "Green"
        Case Else
            SRating = "Amber"
    End Select
   
    If wsVR.Range("K83").Value = "No" Then SRating = "Red"
   
    StrBody = "Dear " & wsVR.Range("G6").Value & "," & "<br>" & _
              "We conducted a detailed LP review of " & wsVR.Range("D4").Value & " Store (" & wsVR.Range("D5").Value & ") " & _
              "as on " & Format(wsVR.Range("D7").Value, "DD-MMM-YYYY") & ". " & "Based on the observations, the store is categorized as " & SRating & "." & "<br>" & _
              "Please find the summary below and request your action plans and corrective measures within three working days." & "<br>" & "</br></br></br>"
    Obs = "Important observations noted are as follows-" & "<br>" & "</br>"
   
    'Create JPG file of the range
    'Only enter the Sheet name and the range address
    MakeJPG = CopyRangeToJPG("Visit Checklist", "P10:X24")
   
    Dim flag  As Boolean                        '<- added
    Dim header  As String                        '<- added
    For Each Cell In wsVR.Range("L11:L83")
        If Not IsEmpty(Cell) Then
            If header <> Cell.Offset(0, -11).MergeArea.Cells(1, 1) Then flag = False 'detect if headerer has changed (new section) then reset flag
            If flag = False Then                  'detect if headerer has already been added to obs
                Obs = Obs & "<br><b><u>" & Cell.Offset(0, -11).MergeArea.Cells(1, 1) & ":</b></u>" 'add headerer to obs
                header = Cell.Offset(0, -11).MergeArea.Cells(1, 1) 'store headerer
                flag = True                      'set flag for headerer already added to obs
            End If
            Obs = Obs & "<br>" & Cell.Value & "</br>"
        End If
    Next Cell
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            '.to =
            .CC = "anishms@msn.com"
            .Subject = "LP Review | Store" & wsVR.Range("D5").Value & " (" & wsVR.Range("D4").Value & ") " & wsVR.Range("D7").Value
            .Attachments.Add Destwb.FullName
            .Attachments.Add MakeJPG, 1, 0
            .HTMLBody = "<html><p>" & StrBody & "</p><img src=""cid:NamePicture.jpg"" width=616.5 height=275.25><p>" & Obs & "</p></html>"
            .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
   
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Kill MakeJPG
   
    Set OutMail = Nothing
    Set OutApp = Nothing
   
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
End Sub


Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    Dim PictureRange As Range


    With ThisWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
       
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            On Error GoTo 0
            Exit Function
        End If
       
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
   
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function

---

Looks good, no issues :clap:.
Once again, glad having been of some help.