VBA：只需通过Excel中的可见单元循环

时间：2016-03-02 00:33:24

标签： excel vba excel-vba outlook

我正在处理一个基于过滤器创建工作簿的宏，并将它们一次一个地发送到电子邮件列表，但是，每封电子邮件可能有多个位置，并且循环正在拾取每个（下一个）单元格，即使它被过滤掉了。示例表：

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

1 个答案:

答案 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的信息。

另外，作为旁注：由于您的代码依赖于一张表中的电子邮件列表并过滤不同表中的数据，如果电子邮件表中的电子邮件在“位置”表中没有行，则会出现意外行为。这可能不是一个问题 - 例如，如果另一组代码构建电子邮件列表 - 但可能需要考虑。

相关问题
最新问题