excelvbaemailoutlookworksheet

Excel VBA attach multiple worksheets in one email

I have two worksheets, one called "In out record_AT" and another called "Site Cable Usage".

I want to create new Site Cable Usage sheet with "In out record_AT" row G number, then attach "In out record_AT" and multiple Site Cable Usage Sheet worksheets in one email but it has the duplicate attachment problem as attached image.

Would anyone can help?

Thank you very much

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

enter image description here

Solution

  • Build a collection of files to attach.

    Option Explicit

Sub Create_Site_Cable_Usage_AT()

    Dim wb As Workbook, ws As Worksheet, rngCopy As Range
    Dim LastRow As Long, r As Long, c As Long
    
    Set wb = ThisWorkbook
      
    Set rngCopy = wb.Sheets("Site Cable Usage").Range("A1:S78")
    With wb.Sheets("In out record_AT")
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        For r = 17 To LastRow
            Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
            rngCopy.Copy ws.Range("A1")
            ws.Cells(10, "B") = .Cells(r, "D")
            ws.Name = "Site Cable Usage" & r
            
            ' adjust column widths
            For c = 1 To rngCopy.Columns.Count
                ws.Columns(c).ColumnWidth = rngCopy.Columns(c).ColumnWidth
            Next
        Next
    End With
    
    Call Send_email_AT
End Sub

Public Sub Send_email_AT()

    Dim wb As Workbook, wsIO As Worksheet, ws As Worksheet
    Dim LastRow As Long, r As Long, s As String
    Dim colAttach As Collection, i As Long, f As String
    Set colAttach = New Collection
    
    Set wb = ThisWorkbook
    Application.ScreenUpdating = False
    
    ' create temp copies of each sheet
    ' In out record_AT Sheet
    Set wsIO = wb.Sheets("In out record_AT")
    f = SaveToTemp(wsIO, wsIO.Name & Format(Now, "dd-mm-yyyy "))
    colAttach.Add f, CStr(0)
    
    ' Site Cable Usage Sheets
    With wsIO
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        For r = 17 To LastRow
            Set ws = wb.Sheets("Site Cable Usage" & r)
            f = SaveToTemp(ws, ws.Name)
            colAttach.Add f, CStr(r)
        Next
    End With
    Application.ScreenUpdating = True
    
    ' create email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    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 ."
                      
        For i = 1 To colAttach.Count
            .Attachments.Add colAttach(i)
            Debug.Print colAttach(i)
        Next
        .display
    End With
    
    ' delete temp files
    If MsgBox("Delete temp files ? ", vbYesNo) = vbYes Then
        For i = 1 To colAttach.Count
            Debug.Print "Deleted " & colAttach(i)
            Kill colAttach(i)
        Next
    End If
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

Function SaveToTemp(ws As Worksheet, s As String)
    
    Dim FileExtStr As String, TempFilePath As String
    Dim FileFormatNum As Long, c As Long
    
    TempFilePath = Environ$("temp") & "\"
    
    ' copy sheet to new workbook
    ws.Copy
    With ActiveWorkbook
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case .FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If ActiveWorkbook.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
        ' save workbook to temp
        s = TempFilePath & s & FileExtStr
        .SaveAs s, FileFormatNum
        .Close
    End With
    ' return full file path and name
    SaveToTemp = s
    
End Function