Email Attachments from Auto-filtered Cell

XfortunaX

New Member
Joined
Aug 28, 2014
Messages
28
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

New Member
Joined
Aug 28, 2014
Messages
28
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
 
Last edited:

XfortunaX

New Member
Joined
Aug 28, 2014
Messages
28
Solved:

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

Forum statistics

Threads
1,082,367
Messages
5,365,028
Members
400,819
Latest member
Gossow

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top