excel VBA代码可以在工作簿中工作，但不能在PERSONAL.XLSB中工作

nhjlsmyf 于 2023-06-25 发布在其他

关注(0)|答案(2)|浏览(146)

我已经在工作簿上创建了VBA代码，该代码将该工作簿中的每个工作表作为附件发送给指定的电子邮件收件人。效果很好。我希望此代码可用于其他工作表，所以我将工作代码添加到我的PERSONAL.XLSB。当我将相同的代码复制到PERSONAL.XLSB时，它不起作用。甚至在原来的工作表上也没有，因为我把代码移到了Personal.XLSB
我在Personal.xlsb中有其他宏可以工作，所以我知道我正确地使用了我的个人宏工作簿。

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

我试着换衣服
ThisWorkbook.Name到ActiveWorkbook.Name和ThisWorkbook.Worksheets到ActiveWorkbook.ActiveWorksheets
但它只会生成一封电子邮件并关闭
任何帮助都将不胜感激

excel

来源：https://stackoverflow.com/questions/76481194/vba-code-works-in-a-workbook-but-not-in-personal-xlsb

2条答案

按热度按时间

nx7onnlm1#

使用变量区分工作簿（发送邮件）

ThisWorkbook是对包含此代码的工作簿的引用，该代码为PERSONAL.xlsb，因此它在代码中没有位置。
使用ActiveWorkbook代替。当你复制一个工作表时，问题就出现了，最常见的情况是，新创建的工作簿变成了（新的）ActiveWorkbook（更安全的是Workbook(Workbooks.Count)），那么你就不能安全地引用初始的ActiveWorkbook。因此，使用变量引用初始值ActiveWorkbook：

Dim swb as Workbook: Set swb = ActiveWorkbook

另一个用于引用新工作簿：dwb。

快速修复

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

赞(0）回复(0）举报 2023-06-25

bxpogfeg2#

`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

结束子对象`

赞(0）回复(0）举报 2023-06-25

我来回答

excel VBA代码可以在工作簿中工作，但不能在PERSONAL.XLSB中工作

2条答案

使用变量区分工作簿（发送邮件）

相关问题

热门标签

最新问答