我有一个客户列表及其发票数据（一个客户可能有一行或多行数据）。我已经汇编了一个来自多个代码的宏脚本来过滤掉客户（基于电子邮件地址）并向他们发送一封带有帐户对帐单的催函。
代码在创建电子邮件时工作正常，但我无法附加第2列中列出的发票副本（在TempoWB工作簿中）。
我认为问题出在Loop代码从Do while直接跳转到.HTMLBody。它正在跳过以前的代码来搜索和附加文件。我该如何解决？
以下是包含所有必需数据和文件的Zip file。如果你想尝试一下。只需将“重命名”发票文件夹复制到C：\ Invoices。
（客户名称和其他数据因合规原因而被更改）
Option Explicit
Sub Dunning_3_Populate_Emails_TempWB()
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 name_rg As Range
Dim name As String
Dim Subj As String
Dim irow As Integer
Dim dpath As String
Dim pfile As String
Dim strbody As String
Dim TempoWB As Workbook
'Folder location for Invoice copies
dpath = "C:\Invoices\Renamed"
'Column number to pick the invoices
irow = 2
Set OutApp = CreateObject("Outlook.Application")
name = Ash.Cells(name_rg.Row, 16)
Subj = Ash.Cells(name_rg.Row, 15)
Else
name = "email not found in Ash"
End If
------------------------------------------------------------------------------
'This portion has codes to filter the required data based on the unique email address
-----------------------------------------------------------------------------
'Create a new workbook with selected/ filtered data
rng.Copy
Set TempoWB = Workbooks.Add(1)
With TempoWB.Sheets(1)
.Cells(1).PasteSpecial
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Columns("O:Q").Select
Selection.Delete Shift:=xlToLeft
On Error GoTo 0
'Location to save the temporary workbook
Application.DisplayAlerts = False
TempoWB.SaveAs Filename:="C:\Invoices\TempoWB.xlsx"
End With
'E-mail body for the dunning letters
strbody = "Hello " & name & "," & "<br>" & "<br>" & _
"<b>Below is the summary of your account and attached are the invoices:</b>" & "<br>" & "<br>"
On Error GoTo Cleanup
On Error Resume Next
With OutMail
.Display
.To = Cws.Cells(Rnum, 1).Value
.Subject = subj
Workbooks("TempoWB.xlsx").Activate
For irow = 2 To Lastrow
.Attachments.Add ("C:\Dunning Temp\" & Cells(irow, 2).Value & ".pdf")
Next
.HTMLBody = strbody & RangetoHTML(rng) & .HTMLBody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
'Close TempoWB
Application.DisplayAlerts = False
Workbooks("TempoWB.xlsx").Close SaveChanges:=False
On Error Resume Next
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
End Sub
答案 0 :(得分：2)
我最初对行计数器的怀疑是错误的。问题结果是几个小错误，只是导致代码在它永远找不到它的地方寻找附件。
你应该知道两件事：
1）您问题中的代码感觉不对，所以我把它扔了，然后使用您最初发布的版本。
2）您需要更新路径/目录字符串并清除我所做的一些注释块。没什么太难的。
Option Explicit 'PO - Option Explicit, use it !
Sub Dunning_3_Populate_Emails()
Dim test1 As Long, test2 As Long
test1 = Timer
Application.ScreenUpdating = False
'This code populates emails to outlook.
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
Dim Subj As String
Dim irow As Integer
Dim dpath As String
Dim pfile As String
Dim strbody As String
dpath = Environ("appdata") & "\VBA\Stack Overflow\Attachments" 'PO - my environment only, delete
' dpath = "C:\Invoices\Renamed" 'PO - original code, use if it is correct or modify
irow = 2
'looping through all the files and sending an mail
Set OutApp = CreateObject("Outlook.Application")
'C:\Users\<UserName>\AppData\Roaming\Microsoft\Signatures 'PO - not my edit, guessing it is here for reference
'----------------------------------------------------------------
'PO - blocked this off because it wasn't related to the problem
' should be perfectly ok to unblock
'----------------------------------------------------------------
' SigString = Environ("appdata") & _
' "\Microsoft\Signatures\My Signature.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:Q" & Ash.Rows.Count)
FieldNum = 17 'Filter column = B because the filter range start in column A
'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 addres 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(17).Find(Cws.Cells(Rnum, 1))
If Not name_rg Is Nothing Then
name = Ash.Cells(name_rg.Row, 16)
Subj = Ash.Cells(name_rg.Row, 15)
Else
name = "email not found in Ash"
End If
Set name_rg = Nothing
strbody = "Hello " & name & "," & "<br>" & "<br>" & _
"Hope you are fine!" & "<br>" & "<br>" & _
"I am writing to share the list of open invoice(s) on your account with <b>Keysight Technologies Inc.</b>" & "<br>" & "<br>" & _
"Please refer to th account statement below and let me know if you show any discrepancy on any of the open invoice(s), so that the required help can be arranged asap to get that resolved." & "<br>" & "<br>" & _
"Also, if the invoice(s) has been paid already, kindly share the payment details" & "<br>" & "<br>" & _
"<mark><i>** Please let me know if you have not recieved invoice copy so that I can arrange the invoice copy for you.</i></mark>" & "<br>" & "<br>" & _
"<b>Below is the summary of your account:</b>" & "<br>" & "<br>"
On Error GoTo Cleanup
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = Subj
'----------------------------------------------------------------
'PO - ranges and objects should be qualified to avoid bugs
' It is very likely Cells() was reading from the last active sheet (Cws)
'----------------------------------------------------------------
'Do While Cells(irow, 2) <> Empty 'PO - unqualified, dangerous
Do While Ash.Cells(irow, 2) <> Empty
'pikcing up file name from column B
'pfile = Dir(dpath & "\*" & Cells(irow, 2) & "*") 'PO - unqualified, dangerous
pfile = Dir(dpath & "\*" & Ash.Cells(irow, 2) & "*")
'checking for file exist in a folder and if its a pdf file
'If pfile <> "" And Right(pfile, 2) = "pdf" Then 'PO - a 2 letter string cannot equal a 3 letter string
If pfile <> "" And Right(pfile, 2) = "xt" Then 'PO - be sure to modify this
.Attachments.Add (dpath & "\" & pfile)
End If
'go to next file listed on the C column
irow = irow + 1
Loop
.HTMLBody = strbody & RangetoHTML(rng) & "<br>" & Signature
.Send
End With
' Set ws = Nothing 'PO - "ws" is undefied, probably "Cws"
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 Collection Letters have been sent and it took only " & 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" 'PO forward slash is wrong syntax
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("O:Q").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
最后，嵌套的while循环是你开始陷入循环的原因。减少代码来说明问题，它看起来像是这样：
Do While Cells(irow, 2) <> Empty
Do While Cells(irow, 2) = Empty
Loop
Loop
几乎总是满足这两个条件，因此如果单元格为空，则会卡在内部循环中，如果单元格已填充，则会卡在外部循环上。