BigDawg15
04-17-2017, 08:39 AM
In the attached workbook, I have modified several macros that create worksheets and save them along with a copy as a pdf to the folder in the adjacent directory path.
This all works fine. The problem I can't figure out is how to print the column headings along with worksheet data in the pdf that is saved when I run the emailpm macro.
This macro was obtained from a website (can't remember which one) and slightly modified for my use. It works fine with the exception of the headings not being included.
Any help would be appreciated.
Thank you in advance,
BigDawg15
Code in case anyone doesn't want to download workbook:
Sub emailpm()
SortSubAreas
Dim OutApp, OutMail As Object
Dim SubArea, DSplit As Variant
Dim eAddress, FName As String
Dim FirstRow, LastRow, EMR As Integer
Dim rng As Range
'Change the worksheet and range for the worksheet containing email addresses
SubArea = Worksheets("email").Range("a1:a4")
Set OutApp = Outlook.Application
'Set the first and last row to the first row of your data
FirstRow = 2
LastRow = 2
'Split your data out as the filename cannot have / in it.
'DSplit = Split(Date - 1, "/")
DSplit = Split(Date, "/")
With ActiveWorkbook.Worksheets(1)
For Each i In SubArea
FirstRow = LastRow 'reset the first row of data to where the last ended.
'loop through matching cells to find the last row of this specific department
Do Until .Cells.Range("C" & LastRow).Value <> i
LastRow = LastRow + 1
Loop
'set range of department with headers
Set rng = Range("A1:H1,A" & FirstRow & ":H" & LastRow - 1)
'set the pdf file name
FName = "C:\Users\A10006\Desktop\Docs\SubArea_" & i & " (" & DSplit(2) & "-" & DSplit(0) & "-" & DSplit(1) & ").pdf"
'save pdf. this needs a different range as it does not need the headers listed separately
Range("A" & FirstRow & ":H" & LastRow - 1).ExportAsFixedFormat xlTypePDF, fileName:=FName
'create the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
EMR = 1 'row where the emails address start.
'loop through email worksheet to find correct department
Do Until ActiveWorkbook.Worksheets(3).Cells.Range("a" & EMR).Value = i
EMR = EMR + 1
Loop
'grab email address
eAddress = ActiveWorkbook.Worksheets(3).Cells.Range("b" & EMR).Value
.To = eAddress
'i set the subject to the pdf file name but you can easily change this to the excel workbook name
.Subject = "SubArea_" & i & " (" & DSplit(2) & "-" & DSplit(0) & "-" & DSplit(1) & ")"
'add pdf
.Body = "Attached is your weekly data report." & vbCrLf & vbCrLf & _
"Thank you," & vbCrLf & "Mike"
.Attachments.Add FName
.Display
End With
Next
End With
Set OutMail = Nothing
Set OutApp = Nothing
SortDateOrder
End Sub
This all works fine. The problem I can't figure out is how to print the column headings along with worksheet data in the pdf that is saved when I run the emailpm macro.
This macro was obtained from a website (can't remember which one) and slightly modified for my use. It works fine with the exception of the headings not being included.
Any help would be appreciated.
Thank you in advance,
BigDawg15
Code in case anyone doesn't want to download workbook:
Sub emailpm()
SortSubAreas
Dim OutApp, OutMail As Object
Dim SubArea, DSplit As Variant
Dim eAddress, FName As String
Dim FirstRow, LastRow, EMR As Integer
Dim rng As Range
'Change the worksheet and range for the worksheet containing email addresses
SubArea = Worksheets("email").Range("a1:a4")
Set OutApp = Outlook.Application
'Set the first and last row to the first row of your data
FirstRow = 2
LastRow = 2
'Split your data out as the filename cannot have / in it.
'DSplit = Split(Date - 1, "/")
DSplit = Split(Date, "/")
With ActiveWorkbook.Worksheets(1)
For Each i In SubArea
FirstRow = LastRow 'reset the first row of data to where the last ended.
'loop through matching cells to find the last row of this specific department
Do Until .Cells.Range("C" & LastRow).Value <> i
LastRow = LastRow + 1
Loop
'set range of department with headers
Set rng = Range("A1:H1,A" & FirstRow & ":H" & LastRow - 1)
'set the pdf file name
FName = "C:\Users\A10006\Desktop\Docs\SubArea_" & i & " (" & DSplit(2) & "-" & DSplit(0) & "-" & DSplit(1) & ").pdf"
'save pdf. this needs a different range as it does not need the headers listed separately
Range("A" & FirstRow & ":H" & LastRow - 1).ExportAsFixedFormat xlTypePDF, fileName:=FName
'create the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
EMR = 1 'row where the emails address start.
'loop through email worksheet to find correct department
Do Until ActiveWorkbook.Worksheets(3).Cells.Range("a" & EMR).Value = i
EMR = EMR + 1
Loop
'grab email address
eAddress = ActiveWorkbook.Worksheets(3).Cells.Range("b" & EMR).Value
.To = eAddress
'i set the subject to the pdf file name but you can easily change this to the excel workbook name
.Subject = "SubArea_" & i & " (" & DSplit(2) & "-" & DSplit(0) & "-" & DSplit(1) & ")"
'add pdf
.Body = "Attached is your weekly data report." & vbCrLf & vbCrLf & _
"Thank you," & vbCrLf & "Mike"
.Attachments.Add FName
.Display
End With
Next
End With
Set OutMail = Nothing
Set OutApp = Nothing
SortDateOrder
End Sub