Hi All,
Could someone help me with below macro. I have spreadsheet with one "Set Up" sheet where on column A is sheet name and column B email address where the sheet should be sent and in column C where that sheet should be CC. The below macro require email address to be stored in each sheet in cell A1. How to change it that macro is going to look to "Set Up" sheet for email addresses.
Could someone help me with below macro. I have spreadsheet with one "Set Up" sheet where on column A is sheet name and column B email address where the sheet should be sent and in column C where that sheet should be CC. The below macro require email address to be stored in each sheet in cell A1. How to change it that macro is going to look to "Set Up" sheet for email addresses.
Code:
Sub Mail_Every_Worksheet()
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A1").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) & " - " & sh.Name & " - " & Format(Now, "yyyy.mm.dd_hh-mm")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("A1").Value
.SentOnBehalfOfName = "accountspayable"
.CC = ""
.BCC = ""
.Subject = "PL Approval List"
.HTMLBody = "Dear Colleague,
" & _
"
" & _
"Please see attached list of invoices that are require approval.
" & _
"
" & _
"Could you review these ASAP and feedback to accountspayable@evotech.co.uk
" & _
"
" & _
"With Kind Regards
" & _
"Accounts Payable
" & _
"T: 01422 377 541
" & _
"E: accountspayable@ evotech.co.uk
"
.Attachments.Add wb.FullName
.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub