Consulting

Results 1 to 8 of 8

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

  1. #1
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location

    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

    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
    Attached Files Attached Files

  2. #2
    VBAX Contributor rollis13's Avatar
    Joined
    Jun 2013
    Location
    Cordenons
    Posts
    146
    Location
    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.
    '...
    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.
    Last edited by rollis13; 08-01-2022 at 03:13 PM.

  3. #3
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    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.
    Attached Files Attached Files

  4. #4
    VBAX Contributor rollis13's Avatar
    Joined
    Jun 2013
    Location
    Cordenons
    Posts
    146
    Location
    This is what I came up with as per headers in obs. Did some testing, seems okay .
    '...
    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

  5. #5
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    Thanks rollis

  6. #6
    VBAX Contributor rollis13's Avatar
    Joined
    Jun 2013
    Location
    Cordenons
    Posts
    146
    Location
    Thanks for the feedback, glad having been of some help.

  7. #7
    VBAX Mentor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    314
    Location
    I managed to create the codes. Thanks again rollis for the link which was very helpful to prepare the codes

    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

  8. #8
    VBAX Contributor rollis13's Avatar
    Joined
    Jun 2013
    Location
    Cordenons
    Posts
    146
    Location
    Looks good, no issues .
    Once again, glad having been of some help.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •