How to Send excel sheet with email including dynamic cells in subject and body text

R

Ramadan

Board Regular
Joined
Jan 20, 2024
Messages
193
Office Version
  1. 2021
Platform
  1. Windows
I have an excel sheet with a table containing all the members subscriptions details. And every time a member renews his subscription, I need to send email with his membership details to all the team
I had for info. and to print him a new ID.

I had a code in other sheet to send the sheet but I don't know how to modify it to do what I need.
what I need is to include dynamic cells in both of subject and email body as follows:

1- In the Subject I need to include the membership No. in Col "B" which is different every time
2- In the email. body as you can see in image 2 I need to include the membership No. Again in addition to start date in cell "J8" and - to the end date in cell K8

this is how the email should be: if I'm sending email for membership No1 in row No 8 as you can see in the screenshot

Subject: Renewed memership No. (dynamic cell) "B8"

Dear Team

kindly find attached the renewed membership No. ("B8") for the period from (Cell "J8") -dynamic cell- to (Cell "k8") - dynamic cell
please print a new ID according to the details

best Regards

My Outlook Signature

(this code was created on this platform by Mr. @John_w )


VBA Code: 
Public Sub Send_Email()

    Dim outApp As Object 'Outlook.Application
    Dim outMail As Object
    Dim newHTML As String
    Dim ws As Object
    Dim HTML As String, p1 As Long, p2 As Long
    
    Dim filename As String, Body As String, body2 As String, body3 As String, body4 As String
    Dim ToEmail As String, CCEmail As String, myDate As String
    
    
    With ActiveSheet
        filename = .Range("R8").Value
        ToEmail = .Range("R9").Value
        CCEmail = .Range("R10").Value
        Body = .Range("VR11").Value
        body2 = .Range("R12").Value
        body3 = .Range("R13").Value
        body4 = .Range("R14").Value
        
    End With
    
    Dim Path As String, fname As String
    Path = "D:\Desktop\Guards\gurads list.xlsm"
    fname = filename & " - " & Date
    myDate = Format(Now(), "yyyy/MM/dd")

    newHTML = "<p> Dear All,</p>" & _
              "<p>" & body2 & myDate & _
              "<p>" & body3 & "</p>" & "</p>" & _
              "<p>" & body4 & "</p>"
                  
    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(0)

    'Read the default signature HTML in a new email
    
    With outMail
        .GetInspector
        HTML = .HTMLbody
    End With
    
    'Remove first 2 <p> tags in HTMLbody.  In Outlook 2016 and higher both these contain only &nbsp;, resulting in blank paragraphs
    
    p1 = InStr(1, HTML, "<p ", vbTextCompare)
    p2 = InStr(p1 + 1, HTML, "<p ", vbTextCompare)
    p2 = InStr(p2, HTML, "</p>")
    HTML = Left(HTML, p1 - 1) & Mid(HTML, p2 + Len("</p>"))
    
    'Find end of opening body tag and insert new HTML after it
    
    p1 = InStr(1, HTML, "<body", vbTextCompare)
    p1 = InStr(p1, HTML, ">")
    HTML = Left(HTML, p1) & newHTML & Mid(HTML, p1 + 1)

    'Create and send the HTML email
    
    With outMail
        .To = ToEmail
        .CC = CCEmail
        .Subject = filename & " " & myDate
        .HTMLbody = HTML
        .Attachments.Add "D:\Desktop\Guards\gurads list.xlsm"
        .Display
        '.Send
    End With
    
    Set outMail = Nothing
    Set outApp = Nothing

End Sub
Untitled 1.png
Untitled 2.png
 
Sort by date Sort by votes
Try this macro. It loops through the rows in the "Data" sheet from row 8 to row 10 (just 3 rows for testing) and creates and sends an email for each row. If you're happy that it works correctly, simply delete the line lastRow = 10 and it will loop through all the rows from row 8 to the last row in column B.

Your email body text mentions a membership no. or card being attached, however it's not clear to me if a file should be attached to each email because you haven't explained that in your post and therefore I haven't coded that part.

VBA Code: 
Public Sub Send_Membership_Emails()

    Dim outApp As Object 'Outlook.Application
    Dim outMail As Object
    Dim signatureHTML As String, p1 As Long, p2 As Long
    Dim bodyHTML As String, HTML As String
    Dim lastRow As Long, r As Long
    Dim ToEmail As String, CCEmail As String
    Dim EmailSubject As String
   
    ToEmail = "contactramadan@gmail.com"
    CCEmail = "myteam@gmail.com"
   
    Set outApp = CreateObject("Outlook.Application")
   
    With ThisWorkbook.Worksheets("Data")
   
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        lastRow = 10  'temporary line for testing only
   
        For r = 8 To lastRow
               
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value
           
            bodyHTML = "<p>Dear Team,</p>" & _
                       "<p>Kindly find attached the renewed Membership Card No. " & .Cells(r, "B").Value & " for the period from " & .Cells(r, "J").Value & " to " & .Cells(r, "K").Value & "." & _
                       "<p>Please print a new ID according to the details.</p>" & _
                       "<p>Best regards,</p>"
             
            Set outMail = outApp.CreateItem(0)
           
            'Read the default signature HTML in the new email
           
            With outMail
                .GetInspector
                signatureHTML = .HTMLbody
            End With
           
            'Remove first 2 <p> tags in the signature HTML.  In Outlook 2016 and higher both these contain only &nbsp;, resulting in blank paragraphs at the top of the email body
           
            p1 = InStr(1, signatureHTML, "<p ", vbTextCompare)
            p2 = InStr(p1 + 1, signatureHTML, "<p ", vbTextCompare)
            p2 = InStr(p2, signatureHTML, "</p>")
            signatureHTML = Left(signatureHTML, p1 - 1) & Mid(signatureHTML, p2 + Len("</p>"))
           
            'Find end of opening body tag in signature HTML and insert the new body text HTML after it
           
            p1 = InStr(1, signatureHTML, "<body", vbTextCompare)
            p1 = InStr(p1, signatureHTML, ">")
            HTML = Left(signatureHTML, p1) & bodyHTML & Mid(signatureHTML, p1 + 1)
             
            'Create and send the HTML email
           
            With outMail
                .To = ToEmail
                .CC = CCEmail
                .Subject = EmailSubject
                .HTMLbody = HTML
                .Display
                .Send
            End With
       
            Set outMail = Nothing
       
        Next
       
    End With
   
    Set outApp = Nothing

End Sub
 
Last edited:
Upvote 0
Solution
John_w said:
Try this macro. It loops through the rows in the "Data" sheet from row 8 to row 10 (just 3 rows for testing) and creates and sends an email for each row. If you're happy that it works correctly, simply delete the line lastRow = 10 and it will loop through all the rows from row 8 to the last row in column B.

Your email body text mentions a membership no. or card being attached, however it's not clear to me if a file should be attached to each email because you haven't explained that in your post and therefore I haven't coded that part.

VBA Code: 
Public Sub Send_Membership_Emails()

    Dim outApp As Object 'Outlook.Application
    Dim outMail As Object
    Dim signatureHTML As String, p1 As Long, p2 As Long
    Dim bodyHTML As String, HTML As String
    Dim lastRow As Long, r As Long
    Dim ToEmail As String, CCEmail As String
    Dim EmailSubject As String
 
    ToEmail = "contactramadan@gmail.com"
    CCEmail = "myteam@gmail.com"
 
    Set outApp = New Outlook.Application
 
    With ThisWorkbook.Worksheets("Data")
 
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        lastRow = 10  'temporary line for testing only
 
        For r = 8 To lastRow
             
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value & " " & Now
         
            bodyHTML = "<p>Dear Team,</p>" & _
                       "<p>Kindly find attached the renewed Membership Card No. " & .Cells(r, "B").Value & " for the period from " & .Cells(r, "J").Value & " to " & .Cells(r, "K").Value & "." & _
                       "<p>Please print a new ID according to the details.</p>" & _
                       "<p>Best regards,</p>"
           
            Set outMail = outApp.CreateItem(0)
         
            'Read the default signature HTML in the new email
         
            With outMail
                .GetInspector
                signatureHTML = .HTMLbody
            End With
         
            'Remove first 2 <p> tags in the signature HTML.  In Outlook 2016 and higher both these contain only &nbsp;, resulting in blank paragraphs at the top of the email body
         
            p1 = InStr(1, signatureHTML, "<p ", vbTextCompare)
            p2 = InStr(p1 + 1, signatureHTML, "<p ", vbTextCompare)
            p2 = InStr(p2, signatureHTML, "</p>")
            signatureHTML = Left(signatureHTML, p1 - 1) & Mid(signatureHTML, p2 + Len("</p>"))
         
            'Find end of opening body tag in signature HTML and insert the new body text HTML after it
         
            p1 = InStr(1, signatureHTML, "<body", vbTextCompare)
            p1 = InStr(p1, signatureHTML, ">")
            HTML = Left(signatureHTML, p1) & bodyHTML & Mid(signatureHTML, p1 + 1)
           
            'Create and send the HTML email
         
            With outMail
                .To = ToEmail
                .CC = CCEmail
                .Subject = EmailSubject
                .HTMLbody = HTML
                .Display
                .Send
            End With
     
            Set outMail = Nothing
     
        Next
     
    End With
 
    Set outApp = Nothing

End Sub
Click to expand...
@John_w Thank you so much Mr. John I do appreciate your response but i got this error
Untitled3.png
 
Last edited:
Upvote 0
Sorry, I forgot to change that line to use late binding of the Outlook application object. It should be:
VBA Code: 
    Set outApp = CreateObject("Outlook.Application")

Also, replace this line (which appends the date and time to the email subject):
VBA Code: 
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value & " " & Now
with:
VBA Code: 
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value

I've updated my post #2 with the changes.
 
Upvote 0
John_w said:
Sorry, I forgot to change that line to use late binding of the Outlook application object. It should be:
VBA Code: 
    Set outApp = CreateObject("Outlook.Application")

Also, replace this line (which appends the date and time to the email subject):
VBA Code: 
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value & " " & Now
with:
VBA Code: 
            EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value

I've updated my post #2 with the changes.
Click to expand...
@John_w thanks for your efforts it seems to be ok but got another issue as you can see in blow screenshot
And there is one IMPORTANT issue I don't know how it will be achieved. which is how will the macro know that I need to enclose the the details of a specific row in my email ?
Untitled 1.png
 
Upvote 0
Ramadan said:
it seems to be ok but got another issue as you can see in blow screenshot
Click to expand...

Try Googling "The file C:\Users\permission\AppData\Local\Microsoft\Outlook\Permission@ permissions.ost is in use and cannot be accessed."

Ramadan said:
And there is one IMPORTANT issue I don't know how it will be achieved. which is how will the macro know that I need to enclose the the details of a specific row in my email ?
Click to expand...

You could have a column (e.g. column Q) which contains either "Send email" or "Email sent". You would change this cell value to "Send email" when a member renews his subscription or a new member joins. The macro checks column Q and sends the email if the cell value is "Send email" and then changes the cell value to "Email sent". It might be useful to have another column (e.g. R) which contains the date and time when the email was sent. With these changes the For .... Next loop would be:

VBA Code: 
        For r = 8 To lastRow
               
            'Look at column Q cell to see if an email should be sent for this member
           
            If .Cells(r, "Q").Value = "Send email" Then
           
                EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value & " " & Now
               
                bodyHTML = "<p>Dear Team,</p>" & _
                           "<p>Kindly find attached the renewed Membership Card No. " & .Cells(r, "B").Value & " for the period from " & .Cells(r, "J").Value & " to " & .Cells(r, "K").Value & "." & _
                           "<p>Please print a new ID according to the details.</p>" & _
                           "<p>Best regards,</p>"
                 
                Set outMail = outApp.CreateItem(0)
               
                'Read the default signature HTML in the new email
               
                With outMail
                    .GetInspector
                    signatureHTML = .HTMLbody
                End With
               
                'Remove first 2 <p> tags in the signature HTML.  In Outlook 2016 and higher both these contain only &nbsp;, resulting in blank paragraphs at the top of the email body
               
                p1 = InStr(1, signatureHTML, "<p ", vbTextCompare)
                p2 = InStr(p1 + 1, signatureHTML, "<p ", vbTextCompare)
                p2 = InStr(p2, signatureHTML, "</p>")
                signatureHTML = Left(signatureHTML, p1 - 1) & Mid(signatureHTML, p2 + Len("</p>"))
               
                'Find end of opening body tag in signature HTML and insert the new body text HTML after it
               
                p1 = InStr(1, signatureHTML, "<body", vbTextCompare)
                p1 = InStr(p1, signatureHTML, ">")
                HTML = Left(signatureHTML, p1) & bodyHTML & Mid(signatureHTML, p1 + 1)
                 
                'Create and send the HTML email
               
                With outMail
                    .To = ToEmail
                    .CC = CCEmail
                    .Subject = EmailSubject
                    .HTMLbody = HTML
                    .Display
                    .Send
                End With
           
                Set outMail = Nothing
               
                'Update cells Q and R to indicate that an email has been sent
               
                .Cells(r, "Q").Value = "Email sent"
                .Cells(r, "R").Value = Now
       
            End If
           
        Next
 
Upvote 0
John_w said:
Try Googling "The file C:\Users\permission\AppData\Local\Microsoft\Outlook\Permission@ permissions.ost is in use and cannot be accessed."



You could have a column (e.g. column Q) which contains either "Send email" or "Email sent". You would change this cell value to "Send email" when a member renews his subscription or a new member joins. The macro checks column Q and sends the email if the cell value is "Send email" and then changes the cell value to "Email sent". It might be useful to have another column (e.g. R) which contains the date and time when the email was sent. With these changes the For .... Next loop would be:

VBA Code: 
        For r = 8 To lastRow
             
            'Look at column Q cell to see if an email should be sent for this member
         
            If .Cells(r, "Q").Value = "Send email" Then
         
                EmailSubject = "Renewed membership No. " & .Cells(r, "B").Value & " " & Now
             
                bodyHTML = "<p>Dear Team,</p>" & _
                           "<p>Kindly find attached the renewed Membership Card No. " & .Cells(r, "B").Value & " for the period from " & .Cells(r, "J").Value & " to " & .Cells(r, "K").Value & "." & _
                           "<p>Please print a new ID according to the details.</p>" & _
                           "<p>Best regards,</p>"
               
                Set outMail = outApp.CreateItem(0)
             
                'Read the default signature HTML in the new email
             
                With outMail
                    .GetInspector
                    signatureHTML = .HTMLbody
                End With
             
                'Remove first 2 <p> tags in the signature HTML.  In Outlook 2016 and higher both these contain only &nbsp;, resulting in blank paragraphs at the top of the email body
             
                p1 = InStr(1, signatureHTML, "<p ", vbTextCompare)
                p2 = InStr(p1 + 1, signatureHTML, "<p ", vbTextCompare)
                p2 = InStr(p2, signatureHTML, "</p>")
                signatureHTML = Left(signatureHTML, p1 - 1) & Mid(signatureHTML, p2 + Len("</p>"))
             
                'Find end of opening body tag in signature HTML and insert the new body text HTML after it
             
                p1 = InStr(1, signatureHTML, "<body", vbTextCompare)
                p1 = InStr(p1, signatureHTML, ">")
                HTML = Left(signatureHTML, p1) & bodyHTML & Mid(signatureHTML, p1 + 1)
               
                'Create and send the HTML email
             
                With outMail
                    .To = ToEmail
                    .CC = CCEmail
                    .Subject = EmailSubject
                    .HTMLbody = HTML
                    .Display
                    .Send
                End With
         
                Set outMail = Nothing
             
                'Update cells Q and R to indicate that an email has been sent
             
                .Cells(r, "Q").Value = "Email sent"
                .Cells(r, "R").Value = Now
     
            End If
         
        Next
Click to expand...
@John_w Wow Mr. John it works like magic :) and very very fast, you are more than professional in excel :) I also did your good suggestion with Col "Q"

Sorry I didn't anwer your first question if i need to attach the file, yes please I need that and also sorry for that last request but I need the body text to refer to some cells because I have arabic text which not accepted in VBA sorry if I didn't ask from begining because I didn't want to make my question more complicated. I tried to take a copy for your original code in my question and did some edit to achive that but didn't succeed to make it work
the body below is exacly what I need to be
here is what I did


VBA Code: 
 Dim body1 As String, body2 As String, body3 As String, body4 As String, body5 As String, body6 As String, body7 As String
    body1 = ws.Range("R12").Value
    body2 = ws.Range("R13").Value
    body3 = ws.Range("R14").Value
    body4 = ws.Range("R15").Value
    body5 = ws.Range("R16").Value
    body6 = ws.Range("R17").Value
    body7 = ws.Range("R18").Value
   
    Dim newHTML As String
    newHTML = "<div dir='rtl' style='font-family:Calibri; font-size:11pt;'>" & _
              "<p>" & body1 & "</p>" & _
               "<p>" & body7 & "</p>" & _
              "<p>" & body2 & " <b>(" & membershipNo & ")</b> " & body3 & " <b>(" & _
              [COLOR=rgb(41, 105, 176)]Cell "J"[/COLOR] & "</b>  -  <b> " & [COLOR=rgb(44, 130, 201)]Cell "K"[/COLOR] & ")</b> " & [COLOR=rgb(41, 105, 176)]Cell "M"[/COLOR] & " </p>" & _
              "<p>" & body4 & "</p>" & _
              "<p>" & body5 & "</p>" & _
              "<p>" & body6 & "</p>" & _
              "</div>"""
 
Upvote 0
@John_w it's ok I will take it as you did and will kee[ the english text
Thank you so much for your kind secind response and help - I reall do apprecaite your help
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Solved
How to include my email signature in VBA
Replies
9
Views
509
Ramadan
R
A
  • Question Question
Add Outlook "Confidential" Sensitivity Label
Replies
2
Views
606
Aviles
A
J
  • Question Question
Send bulk email attachment error
Replies
3
Views
340
JOHATUP
J
D
  • Question Question
How can I add a condition to only create email when the value is less or equal to 30?
Replies
4
Views
152
DarkDrag318
D
P
  • Question Question
Use VBA to send HTML email with excel data
Replies
7
Views
746
Micron
M

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top