Email Attachments from Auto-filtered Cell

[XfortunaX]

Hello,

I am using Excel 2010

The code below works flawlessly on the first time around:

For I = 2 To Range("F" & Rows.Count).End(xlUp).Row
.Attachments.Add Range("F" & I).Value
Next I

The second time around. It adds all of the rows from the first filter and the second, not just visible rows post auto filter. I am looking for the attached to only be what is shown after the filter is applied. As the code continues to run, the last email has 43 attachments (that is the total amount of rows unfiltered).

x = 2
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))

Set Rng = Range("A2", Range("A2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(Outmailitem)

AMEXDate = Sheets("Email").Range("I6").Value
EmployeeName = Rng(2, 1).Value
EmployeeEmail = Rng(2, 2).Value
EmailBody = Sheets("Email").Range("I3").Value
EmailBody = Replace(EmailBody, "Employeename", EmployeeName)
EmailBody = Replace(EmailBody, "AMEXDate", AMEXDate)
Subject = "AMEX Reconciliation Team Bills:" & " " & Sheets("Email").Range("I6").Value

On Error Resume Next

With olMail
.To = EmployeeEmail
.CC = ""
.BCC = ""
.Subject = Subject
.BodyFormat = olFormatHTML
.HTMLBody = EmailBody
.SendUsingAccount = olApp.Session.Accounts.Item(2)

For I = 2 To Range("F" & Rows.Count).End(xlUp).Row
.Attachments.Add Range("F" & I).Value
Next I
.Display 'or use .Display
End With
On Error GoTo 0

Set olMail = Nothing
Set olApp = Nothing

x = x + 1
Next Itm

Any information provided will be greatly appreciated.

Thanks,

Tuna

 

[XfortunaX]

The full code:

Sub ParseItems()

Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim ws As Worksheet
Dim MyArr As Variant
Dim Append As Boolean
Dim Rng As Range, Rng2 As Range
Dim x As Integer, I As Integer
Dim EmailBody As String, vTitles As String
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long, TitleRow As Long

'Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
vCol = 1

'Sheet with data in it
Set ws = Sheets("TeamEmails")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:F1"
TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"

For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
'Sort the temporary list
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
ws.Columns(iCol).Clear

'Turn on the autofilter
ws.Range(vTitles).AutoFilter

x = 2
'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))

Set Rng = Range("A2", Range("A2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)
Set Rng2 = Range("F2", Range("F2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(Outmailitem)

AMEXDate = Sheets("Email").Range("I6").Value
EmployeeName = Rng(2, 1).Value
EmployeeEmail = Rng(2, 2).Value
EmailBody = Sheets("Email").Range("I3").Value
EmailBody = Replace(EmailBody, "Employeename", EmployeeName)
EmailBody = Replace(EmailBody, "AMEXDate", AMEXDate)
Subject = "AMEX Reconciliation Team Bills:" & " " & Sheets("Email").Range("I6").Value

On Error Resume Next

With olMail
.To = EmployeeEmail
.CC = ""
.BCC = ""
.Subject = Subject
.BodyFormat = olFormatHTML
.HTMLBody = EmailBody
.SendUsingAccount = olApp.Session.Accounts.Item(2)

For I = 2 To Rng2
.Attachments.Add Rng2.Value
Next I
.Display 'or use .Display
End With
On Error GoTo 0

Set olMail = Nothing
Set olApp = Nothing

x = x + 1
Next Itm

'Cleanup
ws.Activate
ws.AutoFilterMode = False

' Application.ScreenUpdating = True

MsgBox "All Team American Express Bills have been sent"

End Sub

 

[XfortunaX]

Solved:

For Each Rng In Range("F2", Range("F2").End(xlDown)).Cells.SpecialCells(xlCellTypeVisible)
.Attachments.Add Rng.Value
Next Rng