excelvbaloopsoutlookattachment
Loop adding more attachments than intended
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
Solution
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:
- Scoring values including NA() - Excel 365
- Getting the actual usedrange
- Extract non-contiguous data from multiple sheets while extracting from a list with a loop
- Excel VBA - Skip renaming when cell empty
- Protected Cell warning when returning to original cell after DoubleClick
- how to automatically color the lines for each different word, to make it easier to see the difference
- Java Poi XSSF - create pivot table with multiple expandable columns
- Import Excel to Pandas Dataframe, but preserve order of Day/Month in dates?
- Pass an array to a function from a multidimensional array
- VBA Characters.Delete string over 255 characters
- Conditional Formatting Help - Compare Concat cells and Format Range/Table by row based on matches
- problem with VBA code for vlookup from a few different workbooks
- Partial value font color in red using vba
- VBA to manually position an Excel pivot when AutoSort is blocked
- VBA loop through multi-d array and keep values that meet criteria in one column
- Count the value of the current stock in excel
- Extract time from a date time string in excel
- Easy way to export multiple data.frame to multiple Excel worksheets
- Is it possible for HYPERLINK to spill friendly names?
- Loop inside loop. Stop second loop if condition is met
- Using TEXTJOIN to display table values of numbers within certain criteria
- Add attachement to email with VBA
- How to Save DataFrame to Excel file using filedialog as SaveAs-Dialog in Python?
- Excel MS365: 2-D dynamic array creation problem
- Search the latest saved PDF file in a various folders and copy the latest one to a specific location
- How do I get all the different unique combinations of 3 columns using VBA in Excel?
- Worksheet names in VBE
- Excel macro to identify 0 crossing of the value
- Format Multienumeration Data for Pivot Table
- Using Excel, return 1 for all values >0 WITHOUT using an IF