VBA code works in a workbook but not in PERSONAL.XLSB

I have created VBA code on a workbook that sends each worksheet in that workbook as an attachment to a specified email recipient. It works great. I want this code to be available for use on other worksheets so I added the working code to my PERSONAL.XLSB. When I copy that same code to PERSONAL.XLSB it does not work. Not even on the original worksheet that it had worked on because I moved the code to Personal.XLSB

I have other macros in Personal.xlsb that work so I know I'm utilizing my personal macro workbook correctly.

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

I tried changing

ThisWorkbook.Name to ActiveWorkbook.Name
and
ThisWorkbook.Worksheets to ActiveWorkbook.ActiveWorksheets

but then it only generates one email and closes

Any assistance would be greatly appreciated

Use Variables to Distinguish Between Workbooks (Send Emails)

• ThisWorkbook is a reference to the workbook containing this code which is PERSONAL.xlsb so it has no place in your code.

• Use ActiveWorkbook instead. The problem arises when you copy a sheet, most often, the newly created workbook becomes the (new) ActiveWorkbook (safer is Workbook(Workbooks.Count)), then you cannot safely refer to the initial ActiveWorkbook. Therefore use a variable to reference the initial ActiveWorkbook:

  Dim swb as Workbook: Set swb = ActiveWorkbook
  

  and a different one to reference the new workbooks: dwb.

A Quick Fix

<!-- language: lang-vb -->

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

`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`