Excel VBA多工作表邮件附件重复问题求助

我拥有两个工作表，分别名为"In out record_AT"和"Site Cable Usage"。需要基于"In out record_AT"的G列数据创建多个新的"Site Cable Usage"工作表，随后将"In out record_AT"与这些新工作表一同作为附件添加至同一封邮件，但目前出现了附件重复的问题（详见附图）。

原VBA代码 #

Sub Create_Site_Cable_Usage_AT()

    Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
    Dim LastRow As Long, i As Long
    LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
    For i = 17 To LastRow
        Set copysheet = ThisWorkbook.Sheets("Site Cable Usage")
        copysheet.Activate
        copysheet.Range("A1:S78").Select
        Selection.Copy
        Sheets.Add After:=Sheets(Sheets.Count)
        Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        ActiveSheet.Paste
        ActiveSheet.Name = "Site Cable Usage" & i
        Set copysheet2 = ThisWorkbook.Sheets("Site Cable Usage" & i)
        copysheet2.Range("B10").Value = wSheetStart.Range("D" & i).Value
    Next i
    Call Send_email_AT
    
End Sub

Public Sub Send_email_AT()
    Dim FileExtStr, FileExtStr2, FileExtStr3 As String
    Dim FileFormatNum, FileFormatNum2, FileFormatNum3 As Long
    Dim Sourcewb, Sourcewb2, Sourcewb3 As Workbook
    Dim Destwb, Destwb2, Destwb3 As Workbook
    Dim TempFilePath, TempFilePath2, TempFilePath3 As String
    Dim TempFileName, TempFileName2, TempFileName3 As String
    Dim OutApp, OutApp2, OutApp3 As Object
    Dim OutMail, OutMail2, OutMail3 As Object
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set Sourcewb = ActiveWorkbook
    ActiveWorkbook.Worksheets("In out record_AT").Copy
    Set Destwb = ActiveWorkbook
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "In out record_AT" & " " & Format(Now, "dd-mm-yyyy ")
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Destwb.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    Destwb.Close savechanges:=False
         
    Set Destwb3 = ActiveWorkbook
    Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
    Dim LastRow As Long, i As Long
    LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
    For i = 17 To LastRow
        With Destwb3
           ActiveWorkbook.Worksheets("Site Cable Usage" & i).Copy
            If Val(Application.Version) < 12 Then
                'You use Excel 97-2003
                FileExtStr3 = ".xls": FileFormatNum = -4143
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr3 = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr3 = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr3 = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr3 = ".xls": FileFormatNum = 56
                Case Else: FileExtStr3 = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End With
        TempFilePath3 = Environ$("temp") & "\"
        TempFileName3 = "Site Cable Usage" & i
        Destwb3.SaveAs TempFilePath3 & TempFileName3 & FileExtStr3, FileFormat:=FileFormatNum
       
        On Error Resume Next
        With OutMail
            .SentOnBehalfOfName = "tmyloc@clp.com.hk"
            .To = "alan@a.com"
            .CC = "bob@b.com"
            .BCC = "Tse, Kassie Hoi Yi <kassie.tse@clp.com.hk>; Ng, Lok Yi <ly.lau@clp.com.hk>"
            .Subject = "In Out Record on " & Format(Now, "dd/mm/yyyy ") & "- AT"
            '"You may print the In Out Record to collect the cable." & vbNewLine & "Please do not reply to this email."
            .htmlbody = _
            "<p style='font-family:calibri;font-size:21'>Dear Subcontractor,<br/></p>"
            '.Body = "You may print out In Out Record to collect the cable ."
            .Attachments.Add TempFilePath & TempFileName & FileExtStr
            .Attachments.Add Destwb3.FullName
            .display
        End With
    Next i
    On Error GoTo 0
    
    Destwb3.Close savechanges:=False
    Kill TempFilePath & TempFileName & FileExtStr
    Kill TempFilePath3 & TempFileName3 & FileExtStr3
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

问题原因 #

• 邮件附件添加逻辑错误：在循环创建每个新工作表的临时文件时，每次循环都重复添加了"In out record_AT"附件，导致该文件被多次附加到邮件中。
• 临时文件处理不当：循环内重复对同一个邮件对象执行附件添加操作，且未正确管理每个新工作表临时文件的创建和添加流程。

修正后的VBA代码 #

Sub Create_Site_Cable_Usage_AT()
    Dim wSheetStart As Worksheet
    Dim LastRow As Long, i As Long
    Dim copysheet As Worksheet, newSheet As Worksheet
    
    Set wSheetStart = ThisWorkbook.Sheets("In out record_AT")
    LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
    
    ' 批量创建新工作表
    For i = 17 To LastRow
        Set copysheet = ThisWorkbook.Sheets("Site Cable Usage")
        copysheet.Range("A1:S78").Copy
        
        Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        newSheet.Name = "Site Cable Usage" & i
        
        ' 粘贴列宽和内容
        newSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
        newSheet.Range("A1").PasteSpecial Paste:=xlPasteAll
        
        ' 填充数据
        newSheet.Range("B10").Value = wSheetStart.Range("D" & i).Value
    Next i
    
    Call Send_email_AT
End Sub

Public Sub Send_email_AT()
    Dim FileExtStr As String, FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim TempFilePath As String
    Dim mainAttachPath As String
    Dim siteAttachPaths As Collection
    Dim i As Long, LastRow As Long
    Dim wSheetStart As Worksheet
    Dim tempWB As Workbook
    Dim OutApp As Object, OutMail As Object
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Set Sourcewb = ThisWorkbook
    TempFilePath = Environ$("temp") & "\"
    
    ' 获取文件格式信息
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Sourcewb.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    
    ' 创建主附件：In out record_AT
    Sourcewb.Worksheets("In out record_AT").Copy
    Set tempWB = ActiveWorkbook
    mainAttachPath = TempFilePath & "In out record_AT " & Format(Now, "dd-mm-yyyy ") & FileExtStr
    tempWB.SaveAs mainAttachPath, FileFormat:=FileFormatNum
    tempWB.Close savechanges:=False
    
    ' 收集所有Site Cable Usage临时文件路径
    Set siteAttachPaths = New Collection
    Set wSheetStart = Sourcewb.Sheets("In out record_AT")
    LastRow = wSheetStart.Cells(Rows.Count, "G").End(xlUp).Row
    
    For i = 17 To LastRow
        Sourcewb.Worksheets("Site Cable Usage" & i).Copy
        Set tempWB = ActiveWorkbook
        Dim attachPath As String
        attachPath = TempFilePath & "Site Cable Usage" & i & FileExtStr
        tempWB.SaveAs attachPath, FileFormat:=FileFormatNum
        siteAttachPaths.Add attachPath
        tempWB.Close savechanges:=False
    Next i
    
    ' 创建邮件并添加所有附件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    On Error Resume Next
    With OutMail
        .SentOnBehalfOfName = "tmyloc@clp.com.hk"
        .To = "alan@a.com"
        .CC = "bob@b.com"
        .BCC = "Tse, Kassie Hoi Yi <kassie.tse@clp.com.hk>; Ng, Lok Yi <ly.lau@clp.com.hk>"
        .Subject = "In Out Record on " & Format(Now, "dd/mm/yyyy ") & "- AT"
        .HTMLBody = "<p style='font-family:calibri;font-size:21'>Dear Subcontractor,<br/></p>"
        
        ' 添加主附件
        .Attachments.Add mainAttachPath
        ' 添加所有Site Cable Usage附件
        For Each attachPath In siteAttachPaths
            .Attachments.Add attachPath
        Next attachPath
        
        .Display
    End With
    On Error GoTo 0
    
    ' 清理临时文件
    Kill mainAttachPath
    For Each attachPath In siteAttachPaths
        Kill attachPath
    Next attachPath
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set siteAttachPaths = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

优化说明 #

1. 避免重复添加主附件：将主附件的添加移到循环外，只执行一次。
2. 统一收集附件路径：先创建所有临时文件并收集路径，再一次性添加到邮件，避免循环内重复操作邮件对象。
3. 简化代码结构：移除冗余变量，优化工作表复制和粘贴逻辑，避免使用Select/Activate操作，提升代码稳定性。
4. 完善临时文件清理：确保所有创建的临时文件都被正确删除。

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