我正在处理一个基于过滤器创建工作簿的宏，并将它们一次一个地发送到电子邮件列表，但是，每封电子邮件可能有多个位置，并且循环正在拾取每个（下一个）单元格，即使它被过滤掉了。示例表：
Location Email
1 asd@asd.com
2 asd@asd.com
3 asd@asd.com
4 qwe@qwe.com
我使用另一张工作表来过滤每个唯一的电子邮件，然后将这些位置加载到一个数组中，以便过滤表格。过滤该表后，将内容复制并粘贴到新工作簿中，临时保存，将其附加到电子邮件中并发送出去。问题是，当我到达第二个唯一的电子邮件时，电子邮件包含前一行（位置2和3）的值，依此类推。这是代码：
Sub AutoEmailSend()
Dim rng As ListObject
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim TempFilePath As String
Dim TempFileName As String
Dim TempWB As Workbook
Dim LastRow As Long
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Detail Aging").ListObjects("Locations")
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Dim strbody As String
strbody = Worksheets("Body").Range("A1")
Dim strbody2 As String
strbody2 = Worksheets("Body").Range("A2")
Dim strbody3 As String
strbody3 = Worksheets("Body").Range("A3")
Dim strbody4 As String
strbody4 = Worksheets("Body").Range("A4")
Dim strbody5 As String
strbody5 = Worksheets("Body").Range("A5")
On Error GoTo cleanup
For Each cell In Sheets("Emails").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Sheets("Locations").Range("A1:R1").AutoFilter Field:=12, Criteria1:=cell.Value
Dim RngOne As Range, cell2 As Range
Dim LastCell As Long
Dim arrList() As String, lngCnt As Long
With Sheets("Locations")
LastCell = .Range("D" & Sheets("Locations").Rows.Count).End(xlUp).Row
Set RngOne = .Range("D2:D" & LastCell)
End With
'load values into an array
lngCnt = 0
For Each cell2 In RngOne
If Not cell2.EntireRow.Hidden Then
ReDim Preserve arrList(lngCnt)
arrList(lngCnt) = cell2.Text
lngCnt = lngCnt + 1
End If
Next cell2
Sheets("Detail Aging").Range("A1:I1").AutoFilter Field:=1, Criteria1:=arrList, Operator:=xlFilterValues
With Worksheets("Detail Aging").ListObjects("Locations").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Locations[[#Headers],[#Data],[Days Late]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Body").Range("B1").Formula = "=TEXT(Locations[[#Totals],[Total Balance]], ""$#,##0.00._);($#,##0.00)."")"
Dim strbody6 As String
strbody6 = Worksheets("Body").Range("B1")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Cells(cell.Row, "M").Value & "; " & Cells(cell.Row, "N").Value & "; " & Cells(cell.Row, "O").Value & "; " & Cells(cell.Row, "S").Value
.Subject = "Aging Report | " & Cells(cell.Row, "C").Value & " | " & Cells(cell.Row, "F").Value & " | " & Cells(cell.Row, "T").Value
.HTMLBody = "<BODY style=font-size:11pt;font-family:Arial>Dear Valued Customer,<BR><BR>" & _
strbody & "<BR><BR>" & _
strbody2 & "<B>" & strbody6 & "</B>" & " " & strbody3 & "<BR><BR>" & _
strbody4 & "<BR><BR>" & _
strbody5 & "<BR><BR>" & _
"<i><u>Please use ""Reply All"" when replying to this email. AR@Company.com is not a monitored email address.</u></i><BR><BR>" & _
"Thank you for your business!</BODY><BR>" & _
"<BODY style=font-size:12pt;font-family:Arial><B>" & Cells(cell.Row, "A").Value & " | <font color=""#d52427"">Company</font></B><BR>" & _
"<span style=font-size:11pt;font-family:Arial>" & Cells(cell.Row, "Q").Value & "<BR>" & _
Cells(cell.Row, "R").Value & "<BR>" & _
Cells(cell.Row, "S").Value & "<BR>" & _
"<font color=""#d52427"">www.Company.com</font></span></body><BR>"
rng.Range.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add (1)
Set TempWB = ActiveWorkbook
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
.Cells.EntireColumn.AutoFit
.Range("A1:J1").AutoFilter
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
.Name = "Aging Report"
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Aging Report " & Format(Now, "dd-mm-yy hh-mm-ss") & ".xlsx"
TempWB.SaveAs TempFilePath & TempFileName
.Attachments.Add TempWB.FullName
TempWB.Close savechanges:=False
Kill TempFilePath & TempFileName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
第一封电子邮件是正确的，如：
To: asd@asd.com
Cc: Person1@email.com; Company1@company.com
Subject: Aging Report | Cust1 | Custname1 | Col1
Attachment: Table containing correct details
Body Text Correct
Col1 Name | Company
Pos1
Phone1
Email1
www.Company.com
然而，第二封电子邮件是：
To: qwe@qwe.com
Cc: Person1@email.com; Company1@company.com (Should be Person2 and Company2)
Subject: Aging Report | Cust1 | Custname1 | Col1 (Should be Cust2 and so on)
Attachment: Table containing correct details
Body Text Correct
Col1 Name | Company (Should be Col2 and so on)
Pos1
Phone1
Email1
www.Company.com
我试图提供尽可能多的细节。提前谢谢。
答案 0 :(得分：1)
修改 - 删除旧答案，因为它没有解决OP的问题。
<强>问题
在尝试拉动收集器时，您正在使用电子邮件工作表（cell变量）中的电子邮件地址行。在您的电子邮件＃2示例中，cell.Row为3，因为CustomerEmail2@Customer2.com出现在电子邮件表格的单元格A3中。
<强>解决方案
您需要从“位置”表单中检索第一个可见行号，并在引用中使用它。请注意添加CollectorRow变量。
Sub AutoEmailSend()
Dim rng As ListObject
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim TempFilePath As String
Dim TempFileName As String
Dim TempWB As Workbook
Dim LastRow As Long
Dim CollectorRow As Long
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Detail Aging").ListObjects("Locations")
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Dim strbody As String
strbody = Worksheets("Body").Range("A1")
Dim strbody2 As String
strbody2 = Worksheets("Body").Range("A2")
Dim strbody3 As String
strbody3 = Worksheets("Body").Range("A3")
Dim strbody4 As String
strbody4 = Worksheets("Body").Range("A4")
Dim strbody5 As String
strbody5 = Worksheets("Body").Range("A5")
On Error GoTo cleanup
For Each cell In Sheets("Emails").Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
Sheets("Locations").Range("A1:R1").AutoFilter Field:=12, Criteria1:=cell.Value
Dim RngOne As Range, cell2 As Range
Dim LastCell As Long
Dim arrList() As String, lngCnt As Long
With Sheets("Locations")
LastCell = .Range("D" & Sheets("Locations").Rows.Count).End(xlUp).Row
Set RngOne = .Range("D2:D" & LastCell)
End With
'load values into an array and get first visible row while we are at it
CollectorRow = 0
lngCnt = 0
For Each cell2 In RngOne
If Not cell2.EntireRow.Hidden Then
If CollectorRow = 0 Then CollectorRow = cell2.Row
ReDim Preserve arrList(lngCnt)
arrList(lngCnt) = cell2.Text
lngCnt = lngCnt + 1
End If
Next cell2
Sheets("Detail Aging").Range("A1:I1").AutoFilter Field:=1, Criteria1:=arrList, Operator:=xlFilterValues
With Worksheets("Detail Aging").ListObjects("Locations").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("Locations[[#Headers],[#Data],[Days Late]]"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("Body").Range("B1").Formula = "=TEXT(Locations[[#Totals],[Total Balance]], ""$#,##0.00._);($#,##0.00)."")"
Dim strbody6 As String
strbody6 = Worksheets("Body").Range("B1")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.CC = Cells(CollectorRow, "M").Value & "; " & Cells(CollectorRow, "N").Value & "; " & Cells(CollectorRow, "O").Value & "; " & Cells(CollectorRow, "S").Value
.Subject = "Aging Report | " & Cells(CollectorRow, "C").Value & " | " & Cells(CollectorRow, "F").Value & " | " & Cells(CollectorRow, "T").Value
.HTMLBody = "<BODY style=font-size:11pt;font-family:Arial>Dear Valued Customer,<BR><BR>" & _
strbody & "<BR><BR>" & _
strbody2 & "<B>" & strbody6 & "</B>" & " " & strbody3 & "<BR><BR>" & _
strbody4 & "<BR><BR>" & _
strbody5 & "<BR><BR>" & _
"<i><u>Please use ""Reply All"" when replying to this email. AR@Company.com is not a monitored email address.</u></i><BR><BR>" & _
"Thank you for your business!</BODY><BR>" & _
"<BODY style=font-size:12pt;font-family:Arial><B>" & Cells(CollectorRow, "A").Value & " | <font color=""#d52427"">Company</font></B><BR>" & _
"<span style=font-size:11pt;font-family:Arial>" & Cells(CollectorRow, "Q").Value & "<BR>" & _
Cells(CollectorRow, "R").Value & "<BR>" & _
Cells(CollectorRow, "S").Value & "<BR>" & _
"<font color=""#d52427"">www.Company.com</font></span></body><BR>"
rng.Range.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add (1)
Set TempWB = ActiveWorkbook
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
.Cells.EntireColumn.AutoFit
.Range("A1:J1").AutoFilter
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
.Name = "Aging Report"
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Aging Report " & Format(Now, "dd-mm-yy hh-mm-ss") & ".xlsx"
TempWB.SaveAs TempFilePath & TempFileName
.Attachments.Add TempWB.FullName
TempWB.Close savechanges:=False
Kill TempFilePath & TempFileName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
我在您的测试工作簿上运行了此修改后的代码，第二封电子邮件按预期提供了Customer2的信息。
另外，作为旁注：由于您的代码依赖于一张表中的电子邮件列表并过滤不同表中的数据，如果电子邮件表中的电子邮件在“位置”表中没有行，则会出现意外行为。这可能不是一个问题 - 例如，如果另一组代码构建电子邮件列表 - 但可能需要考虑。