lost_in_the_sauce
Board Regular
- Joined
- Jan 18, 2021
- Messages
- 128
- Office Version
- 365
- Platform
- Windows
I have a workbook that uses the below VBA code to turn each tab into a separate excel file and attach it to an email addressed to the address in cell A2 of each tab. Is there a way to add cells A4:C5 to the body of the email so the recipients can seel the summary without opening the attachment?
VBA Code:
Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xFileExt As String, xTempFilePath As String, xFileName As String
Dim xFileFormatNum As Long
Dim xOlApp As Object, xMailObj As Object
Dim sBody As String
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
xTempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
xFileExt = ".xls": xFileFormatNum = -4143
Else
xFileExt = ".xlsm": xFileFormatNum = 52
End If
Set xOlApp = CreateObject("Outlook.Application")
For Each xWs In ThisWorkbook.Worksheets
If xWs.Range("A2").Value Like "?*@?*.?*" Then
xWs.Copy
Set xWb = ActiveWorkbook
xFileName = xWs.Name
Set xMailObj = xOlApp.CreateItem(0)
xWb.Sheets.Item(1).Range("A2").Value = ""
With xWb
.SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
With xMailObj
'specify the CC, BCC, Subject, Body below
.To = xWs.Range("A2").Value
.CC = ""
.BCC = ""
.Subject = "Update "
sBody = "Monthly Payment Amounts"
.Display
.HtmlBody = sBody & .HtmlBody
.Attachments.Add xWb.FullName
.Display
End With
.Close SaveChanges:=False
End With
Set xMailObj = Nothing
Kill xTempFilePath & xFileName & xFileExt
End If
Next
Set xOlApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub