Loop in outlook adding more attachments than intended - Outlook VBA Excel

[JorgeMartinez]

This script creates emails with invoices for customers. The way it does this is sorting by customer name through a list and then adding the corresponding invoice.

My problem right now is that, although the script is adding the correct invoice for each customer, it is also attaching the previous customers' invoices. Basically, accumlating and adding.

I used the code shown here:

Sending multiple attachments from excel sheet with VBA

I am missing something but can not spot the line. Can anyone point me in the correct direction?

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

 

[Alex Blakenburg]

I might be missing something but it seems to me that it is always adding the same attachments.

        Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
        filePath = ws.Cells(5, 1)
        
        '.... rest of code ....
        
        For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
            .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
        Next i

 

[JorgeMartinez]

I might be missing something but it seems to me that it is always adding the same attachments.

        Set ws = Excel.ThisWorkbook.Worksheets("Hermes")
        filePath = ws.Cells(5, 1)
       
        '.... rest of code ....
       
        For i = 9 To Range("D" & Rows.Count).End(xlUp).Row
            .Attachments.Add filePath & "\" & Cells(i, 4) & ".pdf"
        Next i

Hi Alex,

No. What brings from 5,1 is part of the file path. i.e.: user/desktop/; when is adding the attachments I programmed the script to add the value in i, 4 to complete the path.

 

[RoryA]

But, as Alex said, the file path doesn't change between runs and nor do the cells you are using for the filenames, other than the last row number might change based on your filter.

 

[JorgeMartinez]

But, as Alex said, the file path doesn't change between runs and nor do the cells you are using for the filenames, other than the last row number might change based on your filter.

Hi Rory, now I see Alex's point. Thanks for this!

Someone recommended me to replace the For i = 9 with this script below and it works for multiple attachments, but not when there is a single attachment. When there is only one its throws the run-time error: run time error -2147024894 (80070002) Cannot find this file. Verify the path and file name are correct

For multiple attachments works, but for a single one does not. The run-time error does not make sense to me as it is brining multiple PDFs from the same path for other customer. Do you have any clue on why this might be happening?

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

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

 

[RoryA]

Don't use SpecialCells twice. If the first one returns only one cell, then you run into the issue where applying specialcells to a single cell actually applies it to the entire worksheet. I'd suggest:

Dim attach_cl As Range, attach_range As Range
On Error Resume Next
Set attach_range = ws.Range(ws.Cells(9, "D"), ws.Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeVisible)      'loop only visible data (attachment column) from the filtering
On Error Goto 0
If not attach_Range is nothing then
   For Each attach_cl In attach_range.Cells
       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

 

[JorgeMartinez]

Hi again Rory, Alex

We changed the approach through and IF statement. Still, the issue persists when only on value appears as filtered:

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

Do you have an idea on how to edit the IF that deals with a single invoice?

 

[RoryA]

Well yes - you’re still using specialcells twice.

Edit: You seem to be using a lot of different ranges, so a few questions:
1. Is ws the active sheet? If not, (well, Alex and I would recommend this anyway) you should use:

.Attachments.Add filePath & "\" & attach_cl.value & ".pdf"

2. How is MyRangeFilter assigned?
3. Is your source data a Table?
4. Which row does the actual data start in, as opposed to headers?