Excel VBA attach multiple worksheets in one email

[alantse2010]

Hi all,

I want to attach multiple worksheets in one email but it has the duplicate attachment problem as attached image

Would anyone can help?

Thank you very much


Below is my code:

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

 

[6StringJazzer]

You are attaching the "In out record" file inside the loop, so every time you attach a Site Cable file, you are attaching the same "In out" file over and over again. See change below.

There is also no need to call .display inside the loop, although that is a speed issue; you still get correct results.

        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 ' MOVE THIS LINE OUT OF THE LOOP
            .display ' MOVE THIS LINE OUT OF THE LOOP
        End With
        Next i
        OutMail.Attachments.Add Destwb3.FullName ' DOWN TO HERE
        OutMail.display ' DOWN TO HERE