VBA：只需要通过Excel中的可见单元格循环
我正在创build一个基于filter创build工作簿的macros，并将它们一次一个地发送到一个电子邮件列表中，但是，每个电子邮件可能有多个位置，并且循环正在拾取（next）细胞，即使它被过滤掉。 示例表格：
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
我正尽力提供尽可能多的细节。 先谢谢你。
与示例工作簿链接： https ： //1drv.ms/x/s!At5Qdrytuugrlmt5NcJovACVdiNt
编辑 – 删除旧的答案，因为它没有解决OP的问题。
问题
尝试拉取收集器时，您正在使用“电子邮件”表（ cellvariables）中的电子邮件地址行。 在电子邮件＃2的示例中， cell.Row是3，因为CustomerEmail2@Customer2.com出现在电子邮件表格的单元格A3中。
解
您需要从“位置”表中检索第一个可见的行号，并在您的参考中使用该行号。 请注意添加CollectorRowvariables。
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
我在testing工作簿上运行了这个修改过的代码，第二封电子邮件中包含了Customer2的信息。
此外，请注意：由于您的代码依赖于一张工作表中的电子邮件列表并过滤另一张工作表中的数据，因此如果“电子邮件”工作表中的电子邮件在“位置”工作表中没有行，则会出现意外的行为。 这对您来说可能不是问题 – 例如，如果另一组代码构build了电子邮件列表，但可能需要考虑。