Script is multiplicating attachments on Outlook new message

Question

As stated in the title. I managed, with the help of another user, to finish a script that creates emails with one or multiple attachments. It works like this.

First, the script runs through all the customers names and selects the unique values. After that, it filters one by one. If there is one row for Client 1, this means that the outlook email will have only one attachment; if there are 2 rows, then two attachments, so on and so forth.

My current problem is that the vba is multiplicating the attachments. If client 1 has three rows, it will add the attachments three times, for a total of 9; the goal is to add one one attachment per row.

Can you spot the issue?

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, "A").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, "A"), ws.Cells(lrow_Critera_Data_Range, "A")))        '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:=1, 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("M" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_CC = ws.Range("N" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_BCC = ws.Range("O" & MyRangeFilter.Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Value
    Email_Sub = ws.Range("P" & 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:H" & Range("A8:H8").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, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "D"))).SpecialCells(xlCellTypeVisible)      'loop only visible data (attachment column) from the filtering
 
     If Cells(2, 1) = "PO Number" Then
     
      CountVisible = ws.AutoFilter.Range.Columns(3).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("C" & 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, 3).Value & ".pdf"
            Next attach_cl
        End If
            .HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
            
     Else
     
        CountVisible = ws.AutoFilter.Range.Columns(2).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("B" & 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, 2).Value & ".pdf"
            Next attach_cl
        End If
             .HTMLBody = "<font face=""Arial Nova"">" & StrBody & RangetoHTML(rng) & .HTMLBody
            
      End If
            
    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

Answer 1

Seems like you are missing to change from "D" to "B" in the last part when you set the range for the Set attach_range = (i.e. this part should be changed .End(xlUp).Row, "D")))). Changing this and your code works fine for me.

It should be:

Set attach_range = ws.Range(ws.Cells(9, "B"), ws.Range(ws.Cells(9, "B"), ws.Cells(ws.Cells(Rows.Count, "B").End(xlUp).Row, "B"))).SpecialCells(xlCellTypeVisible)

---

I tested your code with Option Explicit. I would recommend to declare the following variables to make the code more stable:

Dim Email_Addr As String
Dim Email_CC As String
Dim Email_BCC As String
Dim Email_Sub As String
Dim filePath As String
Dim Subject As String