Sending each worksheet by email as separate workbooks is a common request in the Microsoft newsgroups. The following set of procedures splits out the worksheets in a workbook into separate workbooks and emails each one to the recipient of your choice.
The WriteWorksheetsAndEmail procedure first lets you select the folder where you want to save the temporary workbooks. It loops through each sheet and returns the name of the newly saved sheet. Then it calls a function to send the new workbook as an email. Un-comment the line that kills the new workbook if you want to delete it after sending.
Sub WriteWorksheetsAndEmail()
' separate each worksheet into its own workbook and email
On Error GoTo ErrorHandler
Dim wkbk As Excel.Workbook
Dim sht As Excel.Worksheet
Dim folder As String
Dim newWorkbook As String
Set wkbk = ActiveWorkbook
' find or create desktop folder for workbooks
folder = BrowseForFolder
Application.ScreenUpdating = False
' loop through sheets and save each one as new workbook
For Each sht In wkbk.Worksheets
newWorkbook = SaveWorksheet(sht, folder)
' in here you could read some parts of your worksheet to determine where to send it
Call PostMsg("My subject", "My body", "someone@somewhere.com", newWorkbook)
' Kill newWorkbook
Next sht
Application.ScreenUpdating = True
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End SubFunction SaveWorksheet(sht As Excel.Worksheet, folder As String) As String ' saves worksheet as workbook in specified folder (using sheet name) and ' returns string filepath; assumes unique sheet name Dim wkbk As Excel.Workbook Dim wksht As Excel.Worksheet Dim newWkbkSheets As Long newWkbkSheets = Application.SheetsInNewWorkbook ' temporarily reset new sheets count With Application .SheetsInNewWorkbook = 1 .ScreenUpdating = False End With Set wkbk = Excel.Workbooks.Add Set wksht = wkbk.Worksheets(1) sht.Copy Before:=wkbk.Sheets(wksht.Index) Application.DisplayAlerts = False wksht.Delete Application.DisplayAlerts = True wkbk.SaveAs fileName:=folder & sht.Name, FileFormat:=xlNormal SaveWorksheet = wkbk.FullName wkbk.Close True ' reset new sheets count With Application .SheetsInNewWorkbook = newWkbkSheets .ScreenUpdating = True End With End Function
Function PostMsg(subject As String, body As String, recip As String, att As String)
Const olMailItem As Long = 0
Dim ol As Object ' Outlook.Application
Dim Msg As Object ' Outlook.MailItem
Set ol = GetOutlookApp
Set Msg = ol.CreateItem(olMailItem)
With Msg
.Subject = subject
.Body = body
.Recipients.Add recip
.Attachments.Add att
End With
If Msg.Recipients.ResolveAll Then
Msg.Send
Else
Msg.Display
End If
End FunctionFunction GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
End FunctionThese procedures require the BrowseForFolder function which can be found at VBA Express. (I avoid posting it here to avoid the duplicate content penalty some search engines levy.)
Note that this code will trigger the security prompt, specifically via the ResolveAll and Send methods.
If you want to send a workbook other than the active workbook, change
Set wkbk = ActiveWorkbook
to
Set wkbk = wb
and change
Sub WriteWorksheetsAndEmail()
to
Function WriteWorksheetsAndEmail(wb As Excel.Workbook)
Then you can loop through the Workbooks Collection as well:
Dim wb As Excel.Workbook For Each wb in Excel.Workbooks WriteWorksheetsAndEmail(wb) Next wb
This can be part of a larger looping routine that opens and emails each sheet in each workbook in a folder. So much looping!
An alternate method
This is a slightly different method of doing the same thing as above. Instead of several encapsulated functions, it uses a module-level boolean variable to check if Outlook was started by the code.
- If we started Outlook, close it.
- If Outlook was already running, hook it and leave it open.
In both cases, we leave the computer in the same state it was before the code started. Of course in your code, you'll need a way to specify the recipient, body and subject for each worksheet.
' module-level variable to check if we started Outlook
Dim bWeStartedOutlook As Boolean
Sub SendEachWorksheet()
' print error msg if an error occurs
On Error GoTo ErrorHandler
Dim wkbk As Excel.Workbook
Dim wkshts As Excel.Worksheets
Dim wksht As Excel.Worksheet
Dim newWkbk As Excel.Workbook
Dim wkshtName As String
Dim olApp As Object ' Outlook.Application
Dim Msg As Object ' Outlook.MailItem
' change this to point to the workbook you want to split
Set wkbk = ActiveWorkbook
Set wkshts = wkbk.Worksheets
' start Outlook
Set olApp = CreateOutlookApp
If olApp Is Nothing Then GoTo ErrorHandler
' loop through and save each worksheet
For Each wksht In wkshts
wkshtName = "C:\" & wksht.Name
wksht.SaveAs wkshtName
' attach it to a new email
Set Msg = olApp.CreateItem(0)
With Msg
.To = "your email here"
.Body = "your message here"
.Subject = "your subject here"
.Attachments.Add wkshtName
.Send
End With
' delete temp workbook
Kill wkshtName
Next wksht
ProgramExit:
' kill Outlook if we started it
If bWeStartedOutlook Then
olApp.Quit
End If
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Function CreateOutlookApp() As Object
On Error Resume Next
Set CreateOutlookApp = GetObject(, "Outlook.Application")
If CreateOutlookApp Is Nothing Then
Set CreateOutlookApp = CreateObject("Outlook.Application")
If Not CreateOutlookApp Is Nothing Then
bWeStartedOutlook = True
End If
End If
On Error GoTo 0
End FunctionNote the modified version of GetOutlookApp above. It sets the boolean flag to true if Outlook was started with CreateObject, but only does so if Outlook is actually started. That might sound obvious, but it's a necessary step because the On Error Resume Next statement will cause the code to continue even if Outlook isn't started. So after the CreateObject method is executed, Outlook could still not be started (GetOutlookApp = Nothing). We don't want to set the flag in that case.
