ode to send individual email keeps old deleted subject and body

danahoffman · Mar 26, 2014

G'Day to the List. Thanks for all the previous help. I have now have the attached VBA Code to send individual emails per row with their attached row data.

Problem: is New project
Spreadsheet to 13 individuals with all their data on each row to be send to every person as a ticket
However I changed the subject and body of the email and the subject as appropriate for sending a ticket, however on Display the subject and Body are not of the current email but of an older one.
Thanks in advance. VBA Code below.
ALSO I need to know how to send EVERY Column such as Columns A-J in the attachment.
dana hoffman
Colorado Emergency Preparedness partnership
see below

Code to send email with Excel spreadsheet attached.

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image002.png$

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Sub Send_Row_Or_Rows_Attachment_2()

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim OutApp As Object

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim OutMail As Object

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim rng As Range

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim Ash As Worksheet

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim Cws As Worksheet

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim Rcount As Long

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim Rnum As Long

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim FilterRange As Range

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim FieldNum As Integer

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim NewWB As Workbook

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim TempFilePath As String

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim TempFileName As String

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim FileExtStr As String

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Dim FileFormatNum As Long

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

On Error GoTo cleanup

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set OutApp = CreateObject("Outlook.Application")

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With Application

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.EnableEvents = False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.ScreenUpdating = False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Set filter sheet, you can also use Sheets("MySheet")

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set Ash = ActiveSheet

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Set filter range and filter column (column with e-mail addresses)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set FilterRange = Ash.Range("A1:F" & Ash.Rows.Count)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

FieldNum = 2 'Filter column = B because the filter range start in column A

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Add a worksheet for the unique list and copy the unique list in A1

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set Cws = Worksheets.Add

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

FilterRange.Columns(FieldNum).AdvancedFilter _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Action:=xlFilterCopy, _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

CopyToRange:=Cws.Range("A1"), _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

CriteriaRange:="", Unique:=True

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Count of the unique values + the header cell

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'If there are unique values start the loop

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

If Rcount >= 2 Then

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

For Rnum = 2 To Rcount

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'If the unique value is a mail addres create a mail

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

If Cws.Cells(Rnum, 1).Value Like "?*@?*.?*" Then

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Filter the FilterRange on the FieldNum column

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

FilterRange.AutoFilter Field:=FieldNum, _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Criteria1:=Cws.Cells(Rnum, 1).Value

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Copy the visible data in a new workbook

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With Ash.AutoFilter.Range

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

On Error Resume Next

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set rng = .SpecialCells(xlCellTypeVisible)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

On Error GoTo 0

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set NewWB = Workbooks.Add(xlWBATWorksheet)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

rng.Copy

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With NewWB.Sheets(1)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Cells(1).PasteSpecial Paste:=8

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Cells(1).PasteSpecial Paste:=xlPasteValues

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Cells(1).PasteSpecial Paste:=xlPasteFormats

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Columns("A:B").Delete

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Cells(1, 1).Select

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Application.CutCopyMode = False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Create a file name

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

TempFilePath = Environ$("temp") & "\"

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

TempFileName = "Output " & Ash.Parent.Name _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

& " " & Format(Now, "dd-mmm-yy h-mm-ss")

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

If Val(Application.Version) < 12 Then

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'You use Excel 97-2003

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

FileExtStr = ".xls": FileFormatNum = -4143

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Else

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'You use Excel 2007-2013

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

FileExtStr = ".xlsx": FileFormatNum = 51

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End If

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Save, Mail, Close and Delete the file

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set OutMail = OutApp.CreateItem(0)

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With NewWB

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.SaveAs TempFilePath & TempFileName _

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

& FileExtStr, FileFormat:=FileFormatNum

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

On Error Resume Next

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With OutMail

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.To = Cws.Cells(Rnum, 1).Value

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Subject = "CEPP Member – ticket attached, for free admittance to all for “Workshop Sessions", April 7 & 8^th TISP Conference, 2014

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Attachment “Your ticket to the free Workshop Sessions on April 7^th and April 8^th for the TISC Conference is attached.."

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

. Display .Send 'Or use Send

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

On Error GoTo 0

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.Close savechanges:=False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set OutMail = Nothing

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Kill TempFilePath & TempFileName & FileExtStr

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End If

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

'Close AutoFilter

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Ash.AutoFilterMode = False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Next Rnum

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End If

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

cleanup:

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Set OutApp = Nothing

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Application.DisplayAlerts = False

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Cws.Delete

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

Application.DisplayAlerts = True

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

With Application

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.EnableEvents = True

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

.ScreenUpdating = True

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End With

$C:\Users\IX\AppData\Local\Temp\msohtmlclip1\01\clip_image001.png$

End Sub

ode to send individual email keeps old deleted subject and body

danahoffman

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

ode to send individual email keeps old deleted subject and body

danahoffman

New Member

Excel Facts

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock