Hello all,
Here's my issue. I'd like to think there's a way to solve it, but I have no idea how. Any help would be appreciated.
Background: Each week we send an email to each of our contractors telling them how much they’re getting paid for that week. We are creating these emails manually right now and want to automate the process. We start with a table in Excel that shows us all of the work orders. It’s about 1500 rows (one work order per row) and 10 columns, with a header row at the top. It is sorted by contractor. We copy all the work orders (all 10 columns) for each respective contractor and paste it into an email. Additionally, we paste in whatever verbiage into the body of the email and send it out. We do this for about 150 contractors per week, so 150 manual emails with lots of copying and pasting. Big waste of time.
My Steps Thus Far: I have used Ron de Bruin’s guide (Mail Range/Selection in the body of the mail) to automate the process. I’m pretty happy with it. It’s doing what I want in terms of finding the correct data and inserting that data into body of the email, and sending the email. If I didn’t care how it looked I’d be satisfied and ready to go live with it.
Issue I Need Resolved: While the code is inserting the proper portion of the table into each email, what it is not doing is adding the header row from the table. I suppose that the contractor would be able to interpret it all even without the header row but it would look a lot more professional if it had the header row. Any ideas how to do this?
Here’s what I have so far. I’m pretty sure you can disregard everything above where I get Outlook cranked up. Thanks in advance for any ideas.
Here's my issue. I'd like to think there's a way to solve it, but I have no idea how. Any help would be appreciated.
Background: Each week we send an email to each of our contractors telling them how much they’re getting paid for that week. We are creating these emails manually right now and want to automate the process. We start with a table in Excel that shows us all of the work orders. It’s about 1500 rows (one work order per row) and 10 columns, with a header row at the top. It is sorted by contractor. We copy all the work orders (all 10 columns) for each respective contractor and paste it into an email. Additionally, we paste in whatever verbiage into the body of the email and send it out. We do this for about 150 contractors per week, so 150 manual emails with lots of copying and pasting. Big waste of time.
My Steps Thus Far: I have used Ron de Bruin’s guide (Mail Range/Selection in the body of the mail) to automate the process. I’m pretty happy with it. It’s doing what I want in terms of finding the correct data and inserting that data into body of the email, and sending the email. If I didn’t care how it looked I’d be satisfied and ready to go live with it.
Issue I Need Resolved: While the code is inserting the proper portion of the table into each email, what it is not doing is adding the header row from the table. I suppose that the contractor would be able to interpret it all even without the header row but it would look a lot more professional if it had the header row. Any ideas how to do this?
Here’s what I have so far. I’m pretty sure you can disregard everything above where I get Outlook cranked up. Thanks in advance for any ideas.
Code:
Sub Payroll()
'This sub is designed to automate the sending of the weekly payroll emails to vendors
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Application.ScreenUpdating = False
Set Emails = ActiveWorkbook.Worksheets("Emails")
Set Data = ActiveWorkbook.ActiveSheet
'Use the email address list to populate email addresses for each vendor
BRData = Data.Cells(Rows.Count, 11).End(xlUp).Row
BREmails = Emails.Cells(Rows.Count, 2).End(xlUp).Row
'fill email addresses into Data sheet
For i = 2 To BRData
VendorName = Data.Cells(i, 11).Value
For m = 1 To BREmails
If Emails.Cells(m, 2).Value = VendorName Then
Data.Cells(i, 12).Value = Emails.Cells(m, 3).Value
Exit For
End If
Next m
Next i
'look for missing email addresses
MissingEmails = ""
For t = 2 To BRData
If Data.Cells(t, 12).Value = "" Then 'if the emaal column on Data sheet is blank for that row...
If Not Data.Cells(t, 11).Value = Data.Cells(t + 1, 11).Value Then 'the condition is only met when this is the last row for that contractor, such that we're only getting each name once in the msgbox below
VendorMissingEmail = Data.Cells(t, 11).Value
If MissingEmails = "" Then
MissingEmails = MissingEmails & VendorMissingEmail
Else: MissingEmails = MissingEmails & ", " & VendorMissingEmail
End If
End If
End If
Next t
If Not MissingEmails = "" Then 'give msgbox of which contractors don't have an email on the Email address sheet
MsgBox "The following contractors do not have email addresses provided on the Emails sheet:" & vbNewLine & vbNewLine & vbNewLine & MissingEmails & vbNewLine & vbNewLine & vbNewLine & "Please add in the missing email addresses and start over.", , "There are missing email addresses"
Exit Sub
End If
' Now start on the actual data part of this
For d = 2 To BRData
VendorName2 = Data.Cells(d, 11).Value
VendorNameNext = Data.Cells(d + 1, 11).Value
VendorNamePrvs = Data.Cells(d - 1, 11).Value
If Not VendorName2 = VendorNameNext Then
BRCurrentVendor = d 'we have identified the bottom row for this particular vendor and will start to look for the top row for that vendor
For g = 2 To d
If Data.Cells(g, 11).Value = VendorName2 Then
TRCurrentVendor = g 'we have now identified the top row for this particular vendor
Set rng = Data.Range("A" & TRCurrentVendor & ":K" & BRCurrentVendor) 'TRYING TO SET UP THE TABLE
'Now that we have the top and bottom row for this vendor we can send the email.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Define the pieces that will go in the body of the email
Recipient = Data.Cells(d, 12).Value
Vendor_WO_Count = (BRCurrentVendor - TRCurrentVendor) + 1 'not currently using this
Vendor_Total_due = WorksheetFunction.Sum(Range("J" & TRCurrentVendor & ":J" & BRCurrentVendor)) 'not currently using this
'On Error Resume Next
With OutMail
.To = Recipient
.CC = ""
.BCC = ""
.Subject = VendorName2 & " Payroll for the week of..."
.HTMLBody = RangetoHTML(rng)
'.Display
.Send
End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Recipient = 0
Exit For 'exits the G stuff, so it doesn't want to send me an email for each row for that contractor
End If
Next g
'Exit For 'temporary, so I don't have 150 emails pop up...
End If
Next d
MsgBox "DONE"
Application.ScreenUpdating = True
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
