Send email with data from worksheet in the body based on last row of data

J

jbeet

New Member
Joined
Feb 1, 2015
Messages
13
Hello - I have a workbook which I am using as a data entry form. The goal is, once I click the Submit button on the "Form" tab, the data will be entered into the next available row on the "Database" tab. Then an email should open and populate with details from the submitted record (only the newest submitted record).

The form works great. I am working on the email piece and am running into some errors. For every error I find a solution to it seems like I find more!

On the "Database" tab - I have used the Offset function in the Name Manager to name the range for each of the pieces of data that I need to add into the email body or subject line of the email. I feel like I just keep adding things to the code and I am not sure if they are even needed.

I want this to be dynamic. There will be only one user in the workbook entering data at any given time. The data entered into the form needs to come from the data that is currently being submitted from the form. Below is the current code I am using:

VBA Code: 
''''''''''''''''''''''''Send Email''''''''''''''''''''''''''''

    Dim strDate As String
    Dim Signature As String
    Dim sTempPath As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Range
    Dim SP As Range ' Service Provider
    Dim CN As Range ' Client Name
    Dim CP As Range ' Client Policy
    Dim ClaimN As Range ' Claim Number
    Dim V As Range ' VIN
    Dim PN As Range ' Phone Number
    Dim JID As Range ' Job ID
    Dim JT As Range ' Job Type
    Dim CT As Range ' Concern Type
    Dim DR As Range ' Date Received
    Dim S As Range ' Synopsis
    Dim cUser As String
    Dim ws As Worksheet
    Dim wb As Workbook
    On Error GoTo Whoa
      
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Set wb = ActiveWorkbook
    Set ws = Sheets("Database").Range("A1").Select
    Selection.End(xlDown).Select
    

    SP = ActiveCell.Offset(0, 1).Value 'Service Provider
    CN = ActiveCell.Offset(0, 2).Value 'Client Name
    CP = ActiveCell.Offset(0, 3).Value 'Client Policy
    ClaimN = ActiveCell.Offset(0, 4).Value 'Claim Number
    V = ActiveCell.Offset(0, 5).Value 'VIN
    PN = ActiveCell.Offset(0, 6).Value 'Phone Number
    JID = ActiveCell.Offset(0, 9).Value 'Job ID
    JT = ActiveCell.Offset(0, 11).Value 'Job Type
    CT = ActiveCell.Offset(0, 10).Value 'Concern Type
    DR = ActiveCell.Offset(0, 12).Value 'Date Received
    S = ActiveCell.Offset(0, 14).Value 'Synopsis

    strDate = Format(Date, "mm-dd-yy") & " @ " & Format(Time, "hh:mm AM/PM")
    cUser = Environ$("Username")
   sTempPath = "C:\Users\" & cUser & "\AppData\Local\Temp\"
With OutMail
        .Display
    End With
        Signature = OutMail.HTMLBody
       
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Escalation" & " " & CN & " " & strDate & " " & "Audits are ready for review " & " " & JID & ""
        .Body = "<body style='font-family:calibri;font-size:15'>" & "Hello," & "<br><br>" & " I am inquiring about our insured experience in reference to Job ID Number" & _
        " " & JID & " " & "Please see the below details:  " & "<br><br>" & _
        "Client Name:" & " " & CN & "<br>" & _
        "Client Policy Number:" & " " & PN & "<br>" & _
        "Claim Number:" & " " & ClaimN & "<br>" & _
        "VIN:" & " " & V & "<br>" & _
        "Phone Number Called From:" & " " & PN & "<br>" & _
        "Job ID Number:" & " " & JID & "<br>" & _
        "Concern Type:" & " " & CT & "<br>" & _
        "Job Type:" & " " & JT & "<br>" & _
        "Date Received:" & " " & DR & "<br>" & _
        "Synopsis:" & " " & S & "<br><br>" & _
"Please research this and let us know of your findings. Also, please contact the insured to discuss the situation and apologize. " & _
"For any further questions and resolution, you may reach the client at" & " " & PN & "<br><br>" & _
"</body>" & Signature
       
        .Display

    End With


      
    On Error GoTo 0
Set OutMail = Nothing
    Set OutApp = Nothing
    
LetsContinue:
    Application.DisplayAlerts = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue

Thank you for your help!!
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
This is something else I tried. I don't know if I am getting closer or further away lol

VBA Code: 
     Set ws = ThisWorkbook.Sheets("Database")
     ws.Range("A1").Activate
     
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    lastRow = Range("A1" & Rows.Count).End(xlUp).Row
    
    Set SP = Range("Service_Provider" & lastRow)
    Set CN = Range("Client_Name" & lastRow)
    Set CP = Range("Client_Policy" & lastRow)
    Set ClaimN = Range("Claim_Number" & lastRow)
    Set V = Range("VIN" & lastRow)
    Set PN = Range("Phone_Number" & lastRow)
    Set JID = Range("Job_ID" & lastRow)
    Set JT = Range("Job_Type" & lastRow)
    Set CT = Range("Concern_Type" & lastRow)
    Set DR = Range("Date_Received" & lastRow)
    Set S = Range("Synopsis" & lastRow)
 
Upvote 0
Ok , so I made some changes to the original code and I posted it below. I am no longer getting any errors in this piece of the code however I haven't been able to figure out how to make sure that each variable is referencing the last row in the range.

Example: SP (Which stands for Service Provider and has a named range "Service_Provider" on the Database tab is in column A and uses the offset function to expand the range as new data is entered) should be referencing Column A Row 8 currently.


VBA Code: 
''''''''''''''''''''''''Send Email''''''''''''''''''''''''''''

    Dim strDate As String
    Dim Signature As String
    Dim sTempPath As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lastRow As Long
    Dim SP As Range ' Service Provider
    Dim CN As Range ' Client Name
    Dim CP As Range ' Client Policy
    Dim ClaimN As Range ' Claim Number
    Dim V As Range ' VIN
    Dim PN As Range ' Phone Number
    Dim JID As Range ' Job ID
    Dim JT As Range ' Job Type
    Dim CT As Range ' Concern Type
    Dim DR As Range ' Date Received
    Dim S As Range ' Synopsis
    Dim cUser As String
    
   ' On Error GoTo Whoa
         
    lastRow = Worksheets("Database").Cells(Rows.Count, 1).End(xlUp).Row
    MsgBox (lastRow)
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Set SP = Worksheets("Database").Range("Service_Provider")
    Set CN = Worksheets("Database").Range("Client_Name")
    Set CP = Worksheets("Database").Range("Client_Policy")
    Set ClaimN = Worksheets("Database").Range("Claim_Number")
    Set V = Worksheets("Database").Range("VIN")
    Set PN = Worksheets("Database").Range("Phone_Number")
    Set JID = Worksheets("Database").Range("Job_ID")
    Set JT = Worksheets("Database").Range("Job_Type")
    Set CT = Worksheets("Database").Range("Concern_Type")
    Set DR = Worksheets("Database").Range("Date_Received")
    Set S = Worksheets("Database").Range("Synopsis")


    strDate = Format(Date, "mm-dd-yy") & " @ " & Format(Time, "hh:mm AM/PM")
    cUser = Environ$("Username")
   sTempPath = "C:\Users\" & cUser & "\AppData\Local\Temp\"

Thanks again for any help you can provide!
 
Upvote 0
The following will copy the headers in Row 3 ... and copy the last row, then paste both into an email >

VBA Code: 
Option Explicit

Sub Send_Email2()
    
    Dim rngAttach As Range
        
     'Header row 3 and last used row.
    With Sheets("Sheet1")
        Set rngAttach = .Range("A3:H3," & .Range("A" & Rows.Count).End(xlUp).Resize(, 8).Address)
    End With
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = ThisWorkbook.Sheets("Sheet1").Range("H1").Value
        .Subject = ThisWorkbook.Sheets("Sheet1").Range("J1").Value
        .HTMLBody = RangetoHTML(rngAttach)
        'Send
        .Display
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

Function RangetoHTML(rng As Range)
     ' By Ron de Bruin.
    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
 
Upvote 0
Solution
Logit said:
The following will copy the headers in Row 3 ... and copy the last row, then paste both into an email >

VBA Code: 
Option Explicit

Sub Send_Email2()
  
    Dim rngAttach As Range
      
     'Header row 3 and last used row.
    With Sheets("Sheet1")
        Set rngAttach = .Range("A3:H3," & .Range("A" & Rows.Count).End(xlUp).Resize(, 8).Address)
    End With
  
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
  
    With CreateObject("Outlook.Application").CreateItem(0)
        .To = ThisWorkbook.Sheets("Sheet1").Range("H1").Value
        .Subject = ThisWorkbook.Sheets("Sheet1").Range("J1").Value
        .HTMLBody = RangetoHTML(rngAttach)
        'Send
        .Display
    End With
  
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
  
End Sub

Function RangetoHTML(rng As Range)
     ' By Ron de Bruin.
    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
Click to expand...
Thank you Logit! I have seen a lot of references to the code by Ron de Bruin but I have not been able to load the page for whatever reason. I can make this work!

The last question I have is related to the To: and Subject: fields of the email. I want to have the email address listed in column V and the last row populate in the To field. There is a formula in this column of the ws that populates the email address based on the selected service provider. I see in the code you provided the To and Subject fields are referencing cells but not specifically the last cell. Is this possible?

For the Subject: I would really like to be able to populate certain fields in the subject line as I was attempting to do in my original code. For example I would like to have the customer name and the job id populated in the subject line.

Again, thank you for taking the time to help.
 
Upvote 0
VBA Code: 
Sub Send_Email2()
    
    Dim rngAttach As Range
        
     'Header row 3 and last used row.
    With Sheets("Sheet1")
        Set rngAttach = .Range("A3:H3," & .Range("A" & Rows.Count).End(xlUp).Resize(, 8).Address)
    End With
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    With CreateObject("Outlook.Application").CreateItem(0)
    
        .To = ThisWorkbook.Sheets("Sheet1").Range("V" & Rows.Count).End(xlUp).Value
        .Subject = ThisWorkbook.Sheets("Sheet1").Range("W" & Rows.Count).End(xlUp).Value
        
        .HTMLBody = RangetoHTML(rngAttach)
        'Send
        .Display
    End With
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub
 
Upvote 0
Sorry - another question.... Although my default signature is set for new messages, when I run this code the signature does not populate. What do I need to add to make the signature populate for whoever is sending the email?
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Send bulk email attachment error
Replies
3
Views
157
JOHATUP
J
H
  • Solved
Macro to extract text to Body in Email and Table at end of Body
Replies
1
Views
640
howard
H
R
  • Question Question
Inserting a mailto link into an email body to a customer, based on a cell value.
Replies
3
Views
1K
Domenic
D
J
  • Question Question
Outlook Hypperlink of fila in email body will not open
Replies
1
Views
589
josros60
J
F
  • Question Question
VBA run code based off cell value
Replies
1
Views
801
igold
igold

Forum statistics

Threads
1,225,364
Messages
6,184,536
Members
453,239
Latest member
dbenthu

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