I need to send an email with a range of cells from a workbook in the body of the email, and also a different attachent for each recipient.


I am having difficulty with the code below. Everything works as intended except for adding the attachments. When I start the loop to send the emails with their respective
attachments, it includes all the previous iterations' attachments.

That is to say the emails send like this:
Email 1 - Attachment 1
Email 2 - Attachment 1, Attachment 2
Email 3 - Attachment 1, Attachment 2, Attachment 3; and so on.

    Sub Mail()
 
        
        Dim row_nr, n, sup_qty As Integer
        Dim col_3 As Variant
        Dim supplier As String
        Dim filepath As String
        
        
        Application.ScreenUpdating = False
        
        col_3 = Array("A")
        
        filepath = "G:\Pastas\STOCK\3. Supply Chain Store & Sales Connection\2. Supply Chain Connection\1. Ligação ao Negócio\Logistica Inversa"
        
        
        'Recolhe informação dos fornecedores removendo duplicados
        Sheets("BD").Select
        Columns("B:C").Select
        Selection.Copy
        Sheets("Aux").Select
        'Range("A1").Select
        Columns("A:A").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        ActiveSheet.Range("$A$1:$B$200000").RemoveDuplicates Columns:=Array(1, 2), _
            Header:=xlYes
        'ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Aux").Sort.SortFields.Add Key:=Range("A2:A200000") _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets("Aux").Sort
            .SetRange Range("A1:B200000")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        
        
        
        'Sheets("Aux").Select
        
        'ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
        'With ActiveSheet.PivotTables("PivotTable1").PivotFields("SUPPLIER")
        '    .PivotItems("(blank)").Visible = False
        'End With
        
        'Identificação a quantidade de fornecedores
        Range("A2").Select
        Selection.End(xlDown).Select
        sup_qty = ActiveCell.Row
        'sup_qty = 4
            
        
        
        
        
        'Filtros
        For n = 2 To sup_qty
        
        'Limpa a Sheet para envio do mail
        Sheets("Mail_Report").Select
        Range("A2:K2").Select
        Range(Selection, Selection.End(xlDown)).Select
        'Range(Selection, Selection.End(xlToRight)).Select
        Selection.ClearContents
        Range("A2").Select
        
        
        supplier = Sheets("Aux").Range("A" & n).Value
        
        Sheets("BD").Select
        Range("A2").Select
        
        ActiveSheet.Range("$A$1:$K$5914").AutoFilter Field:=2
        ActiveSheet.Range("$A$1:$K$5914").AutoFilter Field:=2, Criteria1:=Sheets("Aux").Range("A" & n).Value
     
        'Identificação da ultima linha
        Range("A2").Select
        Selection.End(xlDown).Select
        row_nr = ActiveCell.Row
        
       
        
        Range("A1:K" & row_nr).Select
        Selection.Copy
        
        Sheets("Mail_Report").Select
        Range("A1").Select
        
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
        
        Range("A2").Select
        
        Sheets("Mail_Report").Select
        Sheets("Mail_Report").Copy
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=filepath & supplier & "_Dev_708.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Grava ficheiro temporário para anexo
        Application.DisplayAlerts = True
        ActiveWindow.Close
        
        'Envio do Email
        
        Dim AWorksheet As Worksheet
        Dim Sendrng As Range
        Dim rng As Range
        'Set Sendrng = Worksheets("Mail_Report").Range("B4:M4", Range("B4:M4").End(xlDown))
        Set Sendrng = Worksheets("Mail").Range("B500000:M500000")
    
        With Sendrng
            
            ' Seleciona a Sheet para enviar
            .Parent.Select
    
            'Seleciona o Range a enviar
            .Select
    
            ' Cria o email e envia
            ActiveWorkbook.EnvelopeVisible = True
            With .Parent.MailEnvelope
                .Introduction = "Boa tarde" & vbNewLine & vbNewLine & vbNewLine & "Relativamente à mercadoria de devoluções comercias a aguardar recolha no entreposto, informo que devem proceder ao seu levantamento, numa data indicada por vós, que deverá ser durante as proximas duas semanas" _
                           
                With .Item
                    
                    .To = Sheets("Aux").Range("C" & n).Value
                    .CC = ""
                    .BCC = ""
                    .Subject = supplier & " - Devoluções 708 - " & Date
                    '.Attachments.Add ActiveWorkbook.FullName
                    .Attachments.Add filepath & supplier & "_Dev_708.xlsx" 'Adiciona o anexo
                    .Send
                    '.display
                End With
                Kill (filepath & supplier & "_Dev_708.xlsx") 'Apaga ficheiro temporário
    
            End With
    
        End With
    
        ActiveWorkbook.EnvelopeVisible = False
    
        Sheets("Mail_Report").Select
        Range("A1").Select
        
        
        'Retira Filtro
        Sheets("BD").Select
        ActiveSheet.Range("$A$1:$K$5914").AutoFilter Field:=2
        Range("A1").Select
        
        Sheets("Mail").Select
        Range("A1").Select
        
         'Espera 2 segundos até ao proximo envio de email
        Application.Wait (Now + TimeValue("0:00:06"))
        
        
        Next n
        
        
        Application.ScreenUpdating = True
        
        
        MsgBox ("Foram enviados " & sup_qty & "!")
        
        
    End Sub
    
    Sub Macro2()
    '
    ' Macro2 Macro
    '
    
    '
        ActiveSheet.PivotTables("PivotTable1").PivotSelect "FLAMA", xlDataAndLabel, _
            True
        ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
        With ActiveSheet.PivotTables("PivotTable1").PivotFields("SUPPLIER")
            .PivotItems("(blank)").Visible = False
        End With
    End Sub
    Sub Macro3()
    '
    ' Macro3 Macro
    '
    
    '
        Range("C12").Select
        Sheets("Aux").Select
        Selection.Copy
        Sheets("Sheet1").Select
        ActiveSheet.Range("$A$1:$K$5914").AutoFilter Field:=2, Criteria1:="835"
        ActiveSheet.Range("$A$1:$K$5914").AutoFilter Field:=2
    End Sub
I believe the code is just reusing the same MailEnvelope object...