VBA loop to send emails with attachments also includes all previous iterations

[Castela95]

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...

[gmayor]

You need to remove the attachments before adding the new one e.g.

While .Attachments.Count > 0
.Attachments.Remove 1
Wend
Do you get the same issue with recipients? If so the solution is similar e.g.

While .Recipients.Count > 0
.Recipients.Remove 1
Wend
While .replyrecipients.Count > 0
.replyrecipients.Remove 1
Wend

[Castela95]

Thank you for your support.

Im pretty much new to vba. Where do i put that attachment removing code?

[gmayor]

Your code includes the following section. Put the extra lines where indicated


With .Item

'code can go here

.To = Sheets("Aux").Range("C" & N).value
.CC = ""
.bCC = ""
.Subject = supplier & " - Devoluções 708 - " & Date
.Attachments.Add FilePath & supplier & "_Dev_708.xlsx" 'Adiciona o anexo
.send
'.display
End With


I