PDA

View Full Version : Macro emailing that includes a spreadsheet sum



HubTOHub
10-30-2015, 05:28 AM
Right.. I'm looking for a macro that does several things. I need a macro to automatically send an email with a text body that includes a bold sentence and 2 hyperlinks. Additionally I'd like the macro to open the most recently modified document in a chosen file, and within this document (which will be an .xls) take 2 seperate sums from the 2 sheets on the excel doc which will be from cells B2 to AW2 down to the bottom row of the doc (which will change in length and size day to day) and then plug these 2 sum totals into a specified sentence within the email.

For example:

"Dear Blah,

Please find the total accepted for todays XYZ: (here will be the sum of one sheet in the document)
And the total accepted for todays ABC: (Here will be the sum of the second sheet in the document):doh:

If you would like to modify the docs please follow: This will be the folder location on a shared drive

Kind regards,

HubTOHub"

A lot to ask I know but would anyone be able to help? :banghead:

Leith Ross
10-31-2015, 09:30 AM
Hello HubTOHub,

That is quite an order. I can write the code for you but need to know some specifics.



What will trigger the email being sent?
Location of the folder with the XLS file.
Name of the XLS file from which the sums will be extracted.
Does this file name change daily?
Is this email for a company intranet only?
What are the URLs of the hyperlinks?

HubTOHub
11-02-2015, 02:04 AM
Hi Leith Ross - thanks for the reply

The macro will be assigned to a shape inserted onto an XLS file. this shape will be acting as a button on a spread sheet that I've been using as a sort of "tool centre" (Its a big sheet of buttons with macros all assigned to them doing different tasks for work). - The trigger for the macro will be clicking this button once the spreadsheets from which the sums are going to be extracted from has been updated with todays info

-The location of the XLS file will be saved in a shared location on the companies shared (F:) Drive (my tool sheet is also saved on the shared (F:) drive but access is locked to me only)

-The name of the file does change everyday (sorry) but keeps always the same format - ddmmyyyyAcceptedVolumesReport

-The email will be sent from Microsoft Outlook for the company intranet only yeah

-The url's for the hyperlinks are the folder locations on the (F:) Drive where the XLS from which the sums will be extracted is stored - this hyperlink is a link for the recipients to view the folder (and then access today's file) of todays accepted volumes report and the associated files (also saved in the same folder) that make up today's accepted volumes report



I hope this really clears things up and let me know if there's anything more I can do to help

Much appreciated,

HubTOHub

Leith Ross
11-02-2015, 10:36 AM
Hello hubTOhub,

Thanks for answering my questions. I have started work on the macro.

Leith Ross
11-02-2015, 12:06 PM
Hello hubTohub,

Here is the macro code so far. You will need to fill a few blanks fro the email and possibly you will need to change the name of the worksheets in the code. The sheet names I used are "Sheet1" and "Sheet2".

The macro does not do an automatic look up of the file yet. I want you to test the code written so far to be sure it works. I will then add in the code to automatically look up the Excel document.

You can copy this code to a Standard VBA module in your workbook's VBA project. You can then attach the macro to your Shape's click event. Test it out and let me know what formatting changes, etc. need to be made.



Sub EmailReportSums()

Dim DocPath As String
Dim Email As String
Dim Folder As String
Dim Link1 As String
Dim Message As String
Dim RngBeg As Range
Dim RngEnd As Range
Dim SendTo As String
Dim Subjec As String
Dim Sum1 As Double
Dim Sum2 As Double
Dim olApp As Object
Dim Wkb As Workbook
Dim Wks1 As Worksheet
Dim Wks2 As Worksheet

SendTo = "" ' Name of the person reveiving the email.
Email = "" ' email address of the person receiving the email.
Subject = "" ' Subject line for this email.

' User selects the file to open.
DocPath = Application.GetOpenFilename("Excel Workbooks (*.xls),*.xls, All Files (*.*),*.*")

' Check if Cancel button was clicked.
If DocPath = "False" Then Exit Sub

' Get the folder path where the Excel file is saved.
Folder = Left(DocPath, InStrRev(DocPath, "\"))

' Create the email hyperlink.
Link1 = "<a href=""" & "file:///" & Folder & """>" & Folder & "</a>"

' Open the Excel workbook.
Set Wkb = Workbooks.Open(Filename:=DocPath, ReadOnly:=True)

' Assign the worksheets to object variables.
Set Wks1 = Wkb.Worksheets("Sheet1")
Set Wks2 = Wkb.Worksheets("Sheet2")

' Get the sum of the range for "Sheet1".
Set RngBeg = Wks1.Range("B2:AW2")
Set RngEnd = Wks1.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum1 = Application.Sum(Wks1.Range(RngBeg, RngEnd))

' Get the sum of the range for "Sheet2".
Set RngBeg = Wks2.Range("B2:AW2")
Set RngEnd = Wks2.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum2 = Application.Sum(Wks1.Range(RngBeg, RngEnd))

' Build the HTML message for the email's body.
Message = "<p>Dear " & SendTo & "," & "<br><br>" _
& "Please find the total accepted for todays <b>XYZ: " & Sum1 & "</b><br>" _
& "And the total accepted for todays <b>ABC: " & Sum2 & "</b><br><br>" _
& "If you would like to modify the docs please follow: " & Link1 & "<br><br>" _
& "Kind regards, <br><br>" & "HubToHub</p>"

' Start Outlook.
Set olApp = CreateObject("Outlook.Application")
olApp.Session.GetDefaultfolder 4

' Send the email.
With olApp.CreateItem(0)
.To = Email
.Subject = Subject
.BodyHTML = Message
.Send
End With

End Sub

HubTOHub
11-04-2015, 08:25 AM
Hi Leith Ross,

Thanks so much for this - so far it works brilliantly (took me a little while to make sure things were pasted into the right location though lol!)

As for the issues I had, I'm not sure if it was me being stupid but I couldn't get it to automatically open on the folder I wanted? It would open on My Documents and I had to navigate to the folder from there?

I also had a little problem with the HTMLBody of the email - I was getting runtime error 438 with the VBA code line highlighting BodyHTML = Message. I removed the "HTML" from this line and the email sent through fine (but obviously it was nonsensical HTML language)

I've also realised (and this is being really cheeky sorry!) that the Sum total for each sheet is in the wrong format - I work in energy forecasting and the data on the sheets I work with comes as standard at MWh for which I then convert to GWh in the email, I.e I divide the sum of each sheet by 1000 quickly and round off to 3 decimal places, would there be a function that did this automatically be any chance?


Once again thankyou very much

HubTOHub

Leith Ross
11-04-2015, 10:09 AM
Hello HubTOHub,

You're welcome and thank you for the feedback on the issues.

It wasn't your fault that the macro did not open up to MyDocuments automatically, I programmed it way to help with troubleshooting. I will change the code to open to MyDocuments automatically.

I will also check out the HTML issue. I probably misspelled something.

No worries with the suffixes for the sums. Easy enough change to make.

Leith Ross
11-04-2015, 12:55 PM
Hello HubTOHub,

Here is the updated code. The parent folder is set to "My Documents". You will need to add the sub-folder path to this if it is needed.

It will search the folder for the most recently modified file. This match is not done by the date in the file but by the system date the file was modified. If this is a problem let me know.

You will need to insert the recipient's name, email address, and subject line into the code. I have sent emails to myself and the code works for me with no problems. The format and the hyperlinks appear to be correct. If not, let me know.

Updated Email Macro

Option Explicit

Sub EmailReportSums()

Dim Email As String
Dim File As Object
Dim Files As Object
Dim Folder As Object
Dim Link1 As String
Dim Message As String
Dim modDate As Date
Dim RngBeg As Range
Dim RngEnd As Range
Dim SendTo As String
Dim SubjecT As String
Dim Sum1 As Double
Dim Sum2 As Double
Dim olApp As Object
Dim oShell As Object
Dim Path As Variant
Dim Wkb As Workbook
Dim Wks1 As Worksheet
Dim Wks2 As Worksheet

SendTo = "" ' Name of the person reveiving the email.
Email = "" ' email address of the person receiving the email.
SubjecT = "" ' Subject line for this email.

' Get the path to My Documents.
Set oShell = CreateObject("Shell.Application")
Set Folder = oShell.Namespace(5)

' Get the path to the subfolder in My Documents where the reports are.
Path = Folder.Self.Path & "\"
Set Folder = oShell.Namespace(Path)

' Find the most recently modified report.
Set Files = Folder.Items
Files.Filter 64, "*.xls"

For Each File In Files
If File.ModifyDate > modDate Then
modDate = File.ModifyDate
Path = File.Path
End If
Next File

' Create the email hyperlink.
Link1 = "<a href=""" & "file:///" & Path & """>" & Path & "</a>"

' Open the Excel workbook.
Set Wkb = Workbooks.Open(Filename:=Path, ReadOnly:=True)

' Assign the worksheets to object variables.
Set Wks1 = Wkb.Worksheets("Sheet1")
Set Wks2 = Wkb.Worksheets("Sheet2")

' Get the sum of the range for "Sheet1".
Set RngBeg = Wks1.Range("B2:AW2")
Set RngEnd = Wks1.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum1 = Application.Sum(Wks1.Range(RngBeg, RngEnd))
Sum1 = Round(Sum1 / 1000, 3)

' Get the sum of the range for "Sheet2".
Set RngBeg = Wks2.Range("B2:AW2")
Set RngEnd = Wks2.Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious, False, False, False)
Sum2 = Application.Sum(Wks1.Range(RngBeg, RngEnd))
Sum2 = Round(Sum2 / 1000, 3)

' Build the HTML message for the email's body.
Message = "<p>Dear " & SendTo & "," & "<br><br>" _
& "Please find the total accepted for todays <b>XYZ: " & Sum1 & " GWh</b><br>" _
& "And the total accepted for todays <b>ABC: " & Sum2 & " GWh</b><br><br>" _
& "If you would like to modify the docs please follow: " & Link1 & "<br><br>" _
& "Kind regards, <br><br>" & "HubToHub</p>"

' Start Outlook.
Set olApp = CreateObject("Outlook.Application")
olApp.Session.GetDefaultfolder 4

' Send the email.
With olApp.CreateItem(0)
.To = Email
.SubjecT = SubjecT
.HTMLBody = Message
.Send
End With

End Sub

HubTOHub
11-05-2015, 03:28 AM
Hi Leith,

That works perfectly! Very grateful! Thanks for all your efforts :bow: :clap: :beerchug:

HubTOHub

Leith Ross
11-05-2015, 08:30 AM
Hello HubToHub,

You're welcome. Cheers! Slàinte mhath!