VBA代码在普通工作簿可用，移入PERSONAL.XLSB后失效求助

核心问题点 #

• ThisWorkbook 引用错误：代码移入PERSONAL.XLSB后，ThisWorkbook指向的是个人宏工作簿本身，而非你当前操作的目标工作簿，导致循环遍历对象完全错误。
• 语法错误：你修改时误用了ActiveWorkbook.ActiveWorksheets，正确写法应为ActiveWorkbook.Worksheets。
• 工作簿引用丢失：复制工作表后ActiveWorkbook会切换到新生成的临时工作簿，后续循环中若不固定目标工作簿的引用，会导致遍历逻辑中断。

修正后的完整代码 #

Sub Mail_Every_Worksheet()
'Updateby ExtendOffice
  Dim xWs As Worksheet
  Dim xWb As Workbook
  Dim TargetWb 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
  Dim recipient As String ' 预存收件人邮箱

  With Application
      .ScreenUpdating = False
      .EnableEvents = False
  End With

  ' 提前锁定当前需要处理的工作簿，避免后续切换工作簿导致引用错误
  Set TargetWb = ActiveWorkbook

  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 TargetWb.Worksheets
    ' 先校验邮箱格式+非空，避免无效循环
    If Not IsEmpty(xWs.Range("S2").Value) And xWs.Range("S2").Value Like "?*@?*.?*" Then
      xWs.Copy
      Set xWb = ActiveWorkbook
      ' 用目标工作簿名称生成文件名
      xFileName = xWs.Name & " - " _
                   & VBA.Left(TargetWb.Name, VBA.InStr(TargetWb.Name, ".") - 1) & " "
      Set xMailObj = xOlApp.CreateItem(0)
      
      ' 修改临时工作簿的S2前，先把收件人邮箱存下来，避免邮件To字段为空
      recipient = xWs.Range("S2").Value
      xWb.Sheets(1).Range("S2").Value = ""
      
      With xWb
        .SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
        With xMailObj
            .To = recipient
            .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 = TargetWb.Name & " for " & xWs.Range("S1").Value
            .Body = "Dear " & xWs.Range("S3").Value
            .Attachments.Add xWb.FullName
            .Display
        End With
        .Close SaveChanges:=False
      End With
      Set xMailObj = Nothing
      ' 延迟1秒再删除临时文件，避免被Outlook占用无法删除
      Application.Wait Now + TimeValue("00:00:01")
      Kill xTempFilePath & xFileName & xFileExt
    End If
  Next
  Set xOlApp = Nothing
  Set TargetWb = Nothing
  With Application
      .ScreenUpdating = True
      .EnableEvents = True
  End With
End Sub

关键修改说明 #

1. 固定目标工作簿引用：新增TargetWb变量，提前赋值为ActiveWorkbook，确保全程遍历的是你当前操作的工作簿，不会因切换临时工作簿而出错。
2. 修正遍历对象：将ThisWorkbook.Worksheets替换为TargetWb.Worksheets，彻底解决引用错误问题。
3. 预存收件人信息：修改临时工作簿的S2单元格前先保存收件人邮箱，避免邮件收件人字段为空。
4. 添加删除延迟：解决临时文件被Outlock占用导致删除失败的问题。

内容的提问来源于stack exchange，提问作者mahen