宏代码如下: Sub Button2_Click() Dim ea As Variant Dim detail As Variant Dim Name, Email As String ea = Sheets("Email Address").[A1].CurrentRegion de = Sheets("Payment Request").[A1].CurrentRegion Dim OutlookApp As Outlook.Application Dim OutlookItem As Outlook.MailItem Set OutlookApp = New Outlook.Application Set OutlookItem = OutlookApp.CreateItem(olMailItem) Dim acc, amm Dim i&, j&, k&, m&, success, error acc = Sheets("Email Address").Range("A1").CurrentRegion amm = Sheets("Payment Request").Range("A1").CurrentRegion success = 0 error = 0 ReDim bcc(1 To UBound(acc, 1), 1 To UBound(acc, 2)) For i = 2 To UBound(acc) Name = acc(i, 1) Email = acc(i, 2) k = 0 m = 0 j = 1 For j = 1 To UBound(amm) If amm(j, 1) = Name Then If k = 0 Then k = j m = j Else m = j End If End If Next 'outlook 发送邮件 If k <> 0 And m <> 0 Then ' On Error GoTo SendEmail_Error With OutlookItem .To = Email .Subject = Name & " 付款申请已支付通知" .HTMLBody = RangetoHTML(Sheets("Travel report application").Range("A1:E1")) & _ RangetoHTML(Sheets("Travel report application").Range("A" & k & ":E" & m)) & "<br><br>" & _ "Your payment request above is wiring today, please check your account in time. " & _ "<br><br>" & "(以上付款申请今天已支付,请通知收款方及时查账。)" & _ "<br><br>" & "XXXX." & _ "<br><br>" & "XXXX。" .Send End With SendEmail_Exit: success = success + 1 Set OutlookItem = Nothing Set OutlookItem = OutlookApp.CreateItem(olMailItem) GoTo Continue SendEmail_Error: error = error + 1 ' MsgBox Err.Description 'Resume SendEmail_Exit ' Exit Sub ' MsgBox ("Name = " & Name & "Email = " & Email & " j = " & j & " k = " & k & " m = " & m) Continue: k = 0 m = 0 End If Next MsgBox ("成功发送邮件" & success & " ; 失败" & error) End Sub 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 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