Consulting

Results 1 to 4 of 4

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

  1. #1

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

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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Thank you for your support.

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

  4. #4
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •