Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim xFileExt As String
  Dim xFileFormatNum As Long
  Dim xTempFilePath As String
  Dim xFileName As String
  Dim xOlApp As Object
  Dim xMailObj As Object
  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("S2").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      xFileName = xWs.Name & " - " _
                   & VBA.Left(ThisWorkbook.Name, VBA.InStr(ThisWorkbook.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      xWb.Sheets.Item(1).Range("S2").Value = ""
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
        'specify the CC, BCC, Subject, Body below
            .To = xWs.Range("S2").Value
            .CC = xWs.Range("S4").Value & ";RSimmons@oldmutual.com;SMfeka@oldmutual.com;MBehari@oldmutual.com;LFurlong@oldmutual.com;KPerumal2@oldmutual.com;IDeVries@oldmutual.com;BEllis@OLDMUTUAL.COM;AMuller4@oldmutual.com"
            .BCC = ""
            .Subject = ThisWorkbook.Name & " for " & xWs.Range("S1")
            .Body = "Dear " & xWs.Range("S3")
            .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

Sub MailEveryWorksheet()
Dim MutualMails(): MutualMails = Array( _
"RSimmons@oldmutual.com", "SMfeka@ oldmutual.com", _
"MBehari@ oldmutual.com", "LFurlong@ oldmutual.com", _
"KPerumal2@ oldmutual.com", "IDeVries@ oldmutual.com", _
"BEllis@ oldmutual.com", "AMuller4@ oldmutual.com")
Dim dTempFolderPath As String: dTempFolderPath = Environ$("temp") & "\"
Dim dFileExtension As String, dFileFormat As Long
If Val(Application.Version) < 12 Then
dFileExtension = ".xls": dFileFormat = -4143
Else
dFileExtension = ".xlsm": dFileFormat = 52
End If
If ActiveWorkbook Is Nothing Then Exit Sub ' no visible workbooks open
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim swbName As String: swbName = swb.Name
Dim DotPosition As Long: DotPosition = InStrRev(swbName, ".")
Dim sBaseName As String
If DotPosition = 0 Then
sBaseName = swbName
Else
sBaseName = Left(swbName, DotPosition - 1)
End If
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim dwb As Workbook, sws As Worksheet
Dim dFileName As String, dFilePath As String
For Each sws In swb.Worksheets
If sws.Range("S2").Value Like "?*@?*.?*" Then
sws.Copy
Set dwb = Workbooks(Workbooks.Count)
dFileName = sws.Name & " - " & sBaseName & " " ' why the space?
dFilePath = dTempFolderPath & dFileName & dFileExtension
With dwb
.Sheets(1).Range("S2").Value = ""
Application.DisplayAlerts = False ' overwrite, no confirmation
.SaveAs dFilePath, dFileFormat
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
With olApp.CreateItem(0)
'specify the CC, BCC, Subject, Body below
.To = sws.Range("S2").Value
.CC = sws.Range("S4").Value & ";" & Join(MutualMails, ";")
.BCC = ""
.Subject = swbName & " for " & sws.Range("S1")
.Body = "Dear " & sws.Range("S3")
.Attachments.Add dFilePath
.Display
'.Send
End With
Kill dFilePath
End If
Next sws
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "Emails sent.", vbInformation
End Sub

Dim MutualMails(): MutualMails = Array( _
"RSimmons@oldmutual.com", "SMfeka@ oldmutual.com", _
"MBehari@ oldmutual.com", "LFurlong@ oldmutual.com", _
"KPerumal2@ oldmutual.com", "IDeVries@ oldmutual.com", _
"BEllis@ oldmutual.com", "AMuller4@ oldmutual.com")
Dim dTempFolderPath As String: dTempFolderPath = Environ$("temp") & "\"
Dim dFileExtension As String, dFileFormat As Long
If Val(Application.Version) < 12 Then
dFileExtension = ".xls": dFileFormat = -4143
Else
dFileExtension = ".xlsm": dFileFormat = 52
End If
If ActiveWorkbook Is Nothing Then Exit Sub ' no visible workbooks open
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim swbName As String: swbName = swb.Name
Dim DotPosition As Long: DotPosition = InStrRev(swbName, ".")
Dim sBaseName As String
If DotPosition = 0 Then
sBaseName = swbName
Else
sBaseName = Left(swbName, DotPosition-1)
End If
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim dwb As Workbook, sws As Worksheet
Dim dFileName As String, dFilePath As String
For Each sws In swb.Worksheets
If sws.Range("S2").Value Like "?*@?*.?*" Then
sws.Copy
Set dwb = Workbooks(Workbooks.Count)
dFileName = sws.Name & " - " & sBaseName & " " ' why the space?
dFilePath = dTempFolderPath & dFileName & dFileExtension
With dwb
.Sheets(1).Range("S2").Value = ""
Application.DisplayAlerts = False ' overwrite, no confirmation
.SaveAs dFilePath, dFileFormat
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
With olApp.CreateItem(0)
'specify the CC, BCC, Subject, Body below
.To = sws.Range("S2").Value
.CC = sws.Range("S4").Value & ";" & Join(MutualMails, ";")
.BCC = ""
.Subject = swbName & " for " & sws.Range("S1")
.Body = "Dear " & sws.Range("S3")
.Attachments.Add dFilePath
.Display
'.Send
End With
Kill dFilePath
End If
Next sws
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "Emails sent.", vbInformation