我创建了一个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
答案 0 :(得分：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