Populating recipient name in Outlook email - excel

Question

I created a vb macro to send emails to listed people in an excel file with their corresponding data table.
Everything is working fine just one problem! After many efforts I could not get/ write a code to get Name of the recipient after Hello in strbody.
Here is the sample file Click here
Link to RangetoHTML function Click here (it needs to be pasted after end sub in below code)
Below is has been fixed and working now. refer to the sample filefor column arrangement
Sub Credit_Auto()
Dim test1 As Long, test2 As Long
test1 = Timer
Application.ScreenUpdating = False
'This code populates emails to outlook as per the Credit analysts.
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 SigString As String
Dim Signature As String
Dim name_rg As Range
Dim name As String
Set OutApp = CreateObject("Outlook.Application")
'You may want to change the signature file path below to get your signature properly
'C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Pratik Kumar2.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
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 e-mail addresses)
Set FilterRange = Ash.Range("A1:G" & Ash.Rows.Count)
FieldNum = 7
'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
'If the unique value is a mail address create a mail
If Cws.Cells(Rnum, 1).Value Like "?*#?*.?*" Then
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
'Search email address from Cws into Ash ~
Set name_rg = Ash.Columns(7).Find(Cws.Cells(Rnum, 1))
If Not name_rg Is Nothing Then
'input the row index of <name_rg>
'returns the name from col 6 ~
name = Ash.Cells(name_rg.Row, 6)
Else
name = "email not found in Ash"
End If
Set name_rg = Nothing
strbody = "Hello " & name & "," & "<br>" & "<br>" & _
"Please allocate the below account(s) to it's appropriate parent account." & "<br>"
On Error GoTo Cleanup
On Error Resume Next
With OutMail
.to = Cws.Cells(Rnum, 1).Value
.Subject = "Unallocated Credit Account"
.HTMLBody = strbody & RangetoHTML(rng) & "<br>" & Signature
.Send
End With
Set Ws = Nothing
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
test2 = Timer
MsgBox "All the Credit Analysts have been notified and the entire process took " & Format((test2 - test1) / 86400, "hh:mm:ss") & " Seconds."
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
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
Columns("E:G").Select
Selection.Delete Shift:=xlToLeft
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
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

Answer 1

You could use the Range.Find Method.
Returns a Range object that represents the first cell where that information
is found. https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-find-method-excel
In your case this code below should do the trick .
Then you could do a loop though all the recipients emails
dim name_rg as range
dim name as string
{...}
' ~ Search email address from Cws into Ash ~
set name_rg = Ash.columns(7).Find(Cws.Cells(Rnum, 1))
If Not name_rg Is Nothing then
' ~ input the row index of <name_rg>
' returns the name from col 6 ~
name = Ash.cells(name_rg.row, 6)
Else
name = "email not found in Ash"
End If
{...}
set name_rg = Nothing