Populating recipient name in Outlook email

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