Loop adding more attachments than intended

Question

This script creates emails with invoices for customers. It sorts by customer name through a list and then adds the corresponding invoice.

The script is adding the correct invoice for each customer.

My problem is it is also attaching the previous customers' invoices. Basically, accumulating and adding.

I used the code shown here: Sending multiple attachments from excel sheet with VBA

'Option Explicit

Sub Filtering()

Application.ScreenUpdating = False
    
    Dim ws          As Worksheet
    Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long
    
    Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
    
    If Sheets("Hermes").AutoFilterMode Then        'If autofilter exists, then remove filter
    Sheets("Hermes").AutoFilterMode = False
End If

'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False        'Remove filter

Dim Critera_Data_Range()        'Range to filter
Dim Unique_Criteria_Data As Object        'Range to filter but with only unique values
Dim Filter_Row      As Long

Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary")        'Create dictionary to store unique values

lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row        'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column        'Last column in filter range

Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C")))        'Get all the Client names

For Filter_Row = 2 To UBound(Critera_Data_Range, 1)        'Start from row 2 (to skip header) and add unique values to the dictionary
    Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1        'Add value to dictionary
Next

'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value    As Variant
Dim MyRangeFilter   As Range

Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range))        'Set filter range

For Each Filter_Value In Unique_Criteria_Data.Keys        'Filter through all the unique names in dictionary "Unique_Criteria_Data"
    'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
    
    With MyRangeFilter
        .AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues        'Filtering the 3rd column and filter the current filter value
    End With
    
    ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy        'copy only visible data from the filtering
    
    Application.CutCopyMode = False        'Clear copy selection
    
    Email_Addr = ws.Range("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_Sub = ws.Range("S" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    
    ' Make all the Dims
    Dim OutApp      As Object
    Dim OutMail     As Object
    Dim SigString   As String
    Dim Signature   As String
    Dim rng         As Range
    Dim lRow        As Long, lCol As Long
    Dim StrBody     As String
    
    'Select the signature to use
    SigString = Environ("appdata") & _
    "\Microsoft\Signatures\" & Cells(2, 7).Text & ".htm"
    
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    On Error Resume Next
    
    ' Set the abbreviations
    Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
    filePath = ws.Cells(5, 1)
    Subject = ws.Cells(2, 5)
    
    StrBody = Cells(5, 3) & "<br><br>" & _
              Cells(5, 4) & "<br>"
        
    'Select the appropriate range to copy and paste into the body of the email
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Hermes").Range("A8:M" & Range("A8:M8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection Is Not valid." & _
               vbNewLine & "Please correct And try again.", vbOKOnly
        Exit Sub
    End If
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'Create email
    With OutMail
        .Subject = Email_Sub & "- " & Subject & Date
        .To = Email_Addr
        .CC = Email_CC
        .Bcc = Email_BCC
        .Importance = 2
        
        For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
        .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
        Next i
        
        .HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
        .SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
        .Display
    End With
    
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    
Next Filter_Value

On Error Resume Next
ws.ShowAllData        'Reset filter
On Error GoTo 0

Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

This is where I am creating the For To. Before this, the script sorts each customer name:

'Create email
    With OutMail
        .Subject = Email_Sub & "- " & Subject & Date
        .To = Email_Addr
        .CC = Email_CC
        .Bcc = Email_BCC
        .Importance = 2
        
        For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
        .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
        Next i
        
        .HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & "<br>" & Signature
        .SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
        .Display
    End With
    
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

Posting the correction by @Wizhi

Sub Filtering()

Application.ScreenUpdating = False
    
    Dim ws          As Worksheet
    Dim lrow_Critera_Data_Range As Long, lcol_Critera_Data_Range As Long

    Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
    
    If Sheets("Hermes").AutoFilterMode Then        'If autofilter exists, then remove filter
    Sheets("Hermes").AutoFilterMode = False
End If

'##### Get all the uniqe filter values #####
ws.AutoFilterMode = False        'Remove filter

Dim Critera_Data_Range()        'Range to filter
Dim Unique_Criteria_Data As Object        'Range to filter but with only unique values
Dim Filter_Row      As Long

Set Unique_Criteria_Data = CreateObject("Scripting.Dictionary")        'Create dictionary to store unique values

lrow_Critera_Data_Range = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row        'Last row in filter range
lcol_Critera_Data_Range = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column        'Last column in filter range

Critera_Data_Range = Application.Transpose(ws.Range(ws.Cells(8, "C"), ws.Cells(lrow_Critera_Data_Range, "C")))        'Get all the Client names

For Filter_Row = 2 To UBound(Critera_Data_Range, 1)        'Start from row 2 (to skip header) and add unique values to the dictionary
    Unique_Criteria_Data(Critera_Data_Range(Filter_Row)) = 1        'Add value to dictionary
Next

'##### Loop through all the unqie Filter values and copy #####
Dim Filter_Value    As Variant
Dim MyRangeFilter   As Range

Set MyRangeFilter = ws.Range(ws.Cells(8, "A"), ws.Cells(lrow_Critera_Data_Range, lcol_Critera_Data_Range))
'Set filter range

For Each Filter_Value In Unique_Criteria_Data.Keys
    'Filter through all the unique names in dictionary "Unique_Criteria_Data"
    'Debug.Print "Current Criteria: " & Filter_Value 'Print current unique Destination Pincode name
    
    With MyRangeFilter
        .AutoFilter Field:=3, Criteria1:=Filter_Value, Operator:=xlFilterValues
        'Filtering the 3rd column and filter the current filter value
    End With
    
    ws.Range(ws.Cells(8, "A"), ws.Range(ws.Cells(8, "A"), ws.Cells(ws.Cells(Rows.Count, "C").End(xlUp).Row, ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column))).SpecialCells(xlCellTypeVisible).Copy
    'copy only visible data from the filtering
    
    Application.CutCopyMode = False        'Clear copy selection
    
    Email_Addr = ws.Range("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_CC = ws.Range("P" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_BCC = ws.Range("Q" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_Sub = ws.Range("S" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    
    ' Make all the Dims
    Dim OutApp      As Object
    Dim OutMail     As Object
    Dim SigString   As String
    Dim rng         As Range
    Dim lRow        As Long, lCol As Long
    Dim StrBody     As String
    
    ' Set the abbreviations
    Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
    filePath = ws.Cells(5, 1)
    subject = ws.Cells(2, 5)
    
    StrBody = Cells(5, 3) & "<br><br>" & _
              Cells(5, 4) & "<br>"
        
    'Select the appropriate range to copy and paste into the body of the email
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Hermes").Range("A8:M" & Range("A8:M8").End(xlDown).Row).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If rng Is Nothing Then
        MsgBox "The selection Is Not valid." & _
               vbNewLine & "Please correct And try again.", vbOKOnly
        Exit Sub
    End If
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'Create email
    With OutMail
        .subject = Email_Sub & "- " & subject & Date
        .To = Email_Addr
        .CC = Email_CC
        .Bcc = Email_BCC
        .Importance = 2
        .SentOnBehalfOfName = Sheets("Hermes").Cells(2, 3).Text
        .Display
       
Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible)      'loop only visible data (attachment column) from the filtering

CountVisible = ws.AutoFilter.Range.Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.

If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
    .Attachments.Add filePath & "\" & ws.Range("D" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
    For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
        'Debug.Print attach_cl 'Check which attachment name currently is in the loop
        .Attachments.Add filePath & "\" & Cells(attach_cl.Row, 4).Value & ".pdf"
    Next attach_cl
End If
        .HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
       
    End With
    
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
    
Next Filter_Value

On Error Resume Next
ws.ShowAllData        'Reset filter
On Error GoTo 0

Application.ScreenUpdating = True

End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

Answer 1

The reason for the "accumulating" is that you always loop through all the cells in the attachment column.

So you filter the data by client name and you only show by filter the visible cells. But the For i loop will loop through all cells from row 9 to last row in column D, regardless if they are filtered or not.

So when you want to get the attachment files you only want to loop through the filtered rows for the specific client. I used a For each loop and set the range to only visible cells. It should do the trick :)

Some trick to use the for each loop. To get the current cell position of the loop I use:

• for current row in the loop: attach_cl.row
• for current column in the loop: attach_cl.column

Change this part:

For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
    .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
Next i

To this:

Dim CountVisible As Long
Dim attach_cl As Range, attach_range As Range
Set attach_range = ws.Range(ws.Cells(9, "D"), ws.Range(ws.Cells(9, "D"), ws.Cells(ws.Cells(Rows.Count, "D").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible)      'loop only visible data (attachment column) from the filtering

CountVisible = ws.AutoFilter.Range.Columns(4).SpecialCells(xlCellTypeVisible).Cells.Count - 1 'Count the visible cells from filtered data. Subtract 1 due to header. Number 4 is the column to check how many rows exists with data.

If CountVisible = 1 Then 'If only one row with data, then add the single attachment file
    .Attachments.Add filePath & "\" & ws.Range("D" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value & ".pdf"
ElseIf CountVisible >= 2 Then 'If more equal or more than 2 files then loop through the visible range and then add the atttachements
    For Each attach_cl In attach_range.SpecialCells(xlCellTypeVisible)
        'Debug.Print attach_cl 'Check which attachment name currently is in the loop
        .Attachments.Add filePath & "\" & Cells(attach_cl.Row, 4).Value & ".pdf"
    Next attach_cl
End If

My setup:

Excel Sheet:

Files in folder: