Any one can help - How to modify macro code for inside the body of email in outlook with - For sending bulk reminder mails approximate 900 mails

[geethanjali63]

Dear All MVP's, I am a very basic user of macro, I can record macro, but repeated steps and coding I am just born baby. We are taking the log every week for pending training videos. In this log keep on increasing, as now it it crossed more than 150,000 rows. So sending reminder mail along with pending details in the body of the message to end user is quite complicated and time consuming. Anyone can help me. In this log only one unique reference number is training account number the user, rest of the column data’s are not suitable for macro. From our log file, this macro need filter one account number then that filtered data should be pasted (only visible cells) in the body of the message after my general welcome message. I tried the macro from one the website,it is working. But when composing each mail same user name (my log file 2nd row user name)(problematic code highlighted below in blue) is repeated in all mails. . Additionally I need to keep my signature bottom of the mail. Only for that mistake I need anyone of your help. Currently in my file I am using Ron de bruin's mail send with excel row and rows. I need the changes in this code only, I tried maximum but not able to solve from my end. My file data is 150,000+ row, as of now. Important condition is per user account,1 reminder mail only, even multiple pending data also. For your information I am using Microsoft excel 2013, Outlook 2013.

1. This macro is copying complete "A" column data from the same file and inserting one new sheets and pasting.

2. Then removing duplicates to reach unique data. This unique value (account number) used for filtering.

3. Now back to sheet 1, and applying filter in column "A" to get the data of one account number. That filtered data's (visible cells) pasted in new workbook (temporary), from that file that data copied and pasted in new mail (outlook) body of the message below my greeting message in outlook mail. before that temporary file is deleted as per coding.

My 2 Requirement is

A. Currently all of the mails going with same person name like Dear XYZ, this XYZ is coming from my main sheet "C" column 2nd cell. Actually I need that the name from temporary file "A" column second cell (account holder name) data to be my email addressing person name (Dear XYZ or ABCD.....)

B. Mail signature should be used bottom of the mail (after the pasted data).


Module 1
Sub Send_Row_Or_Rows_1()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim StrBody As String
Dim myName As String

myName = Range("C2").Value

StrBody = "<H4>Dear " & myName & "," & _
"<H2>Please find the pending training video information,<br><H2>" & _
"Kindly go through the videos ASAP.<br>" & _
"If you are facing any login issue, feel free to contact back to us.<A><br>" & _
"<br><br><B>Thank you</B>"

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With


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


'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:H" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in A


'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True


'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))


'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount


'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value


'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Sheet1").Range("A1:B" & _
Worksheets("Sheet1").Rows.Count), 2, False)
On Error GoTo 0


If mailAddress <> "" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "Test mail"
.HTMLBody = RangetoHTML(rng)
.HTMLBody = StrBody & .HTMLBody
.Display 'Or use Send
End With
On Error GoTo 0


Set OutMail = Nothing
End If


'Close AutoFilter
Ash.AutoFilterMode = False


Next Rnum
End If


cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True


With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub



Module 2 (Function)

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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 xublishsource=", _
"align=left xublishsource=")

'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