在 Outlook 电子邮件中填充收件人姓名

Question

我创建了一个 vb 宏，用于将电子邮件发送给 excel 文件中列出的人员及其相应的数据表。

一切正常，只有一个问题！经过多次努力，我无法获取/编写代码来获取 strbody 中的 Hello 之后的收件人姓名。

这里是示例文件Click here

RangetoHTML函数Click here的链接（需要粘贴在下面代码的end sub之后）

以下内容已修复并正在运行。列排列参考示例文件

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

您可以使用Range.Find 方法。

返回一个 Range 对象，该对象表示该信息所在的第一个单元格 被发现。 https://msdn.microsoft.com/en-us/vba/excel-vba/articles/range-find-method-excel

在您的情况下，下面的代码应该可以解决问题。
然后你可以循环遍历所有收件人的电子邮件

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