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