CODEWITHSUNDEEP
vbaexceloutlook
Fabrizio Martinez
Fabrizio Martinez

Reputation: 61

VBA: Need to loop only through visible cells in Excel

I'm working on a macro that creates Workbooks based on a filter and sends them out to a list of emails, one at a time, however, there may be more than one location per email and the loop is picking up each (next) cell, even if it's filtered out. Example table:

Location Email
1         [email protected]
2         [email protected]
3         [email protected]
4         [email protected]

I use another sheet to filter for each unique email and then load the locations into an array so it filters a table. Once that table is filtered I Copy and paste the contents into a new workbook, save it temporarily, attach it to the email and send it out. The problem is that when I reach the second unique email, the email contains values from previous rows (location 2 and 3) and so on. Here's the code:

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. [email protected] 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

First email is correct like:

To: [email protected]
Cc: [email protected]; [email protected]
Subject: Aging Report | Cust1 | Custname1 | Col1
Attachment: Table containing correct details

Body Text Correct

Col1 Name | Company
Pos1
Phone1
Email1
www.Company.com

Second email however, is something like:

To: [email protected]
Cc: [email protected]; [email protected] (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

I'm trying to provide as many details as possible. Thank you in advance.

Link with sample workbook: https://1drv.ms/x/s!At5Qdrytuugrlmt5NcJovACVdiNt

Upvotes: 0

Views: 511

Answers (1)

Nick Peranzi
Nick Peranzi

Reputation: 1375

Edit - removed old answer as it did not address OP's issue.

Problem

You are using the row of the email address from the Emails sheet (the cell variable) when attempting to pull the collector. In your example of email #2, cell.Row is 3 because [email protected] appears in cell A3 of the Emails sheet.

Solution

You need to retrieve the first visible row number from the Locations sheet and use that in your references. Note the addition of the CollectorRow variable.

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. [email protected] 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

I ran this modified code on your test workbook, and the second email has Customer2's information as intended.

Also, as a side note: since your code relies upon a list of emails in one sheet and filtering data in a different sheet, you would have unexpected behavior if an email in the Emails sheet had no lines in the Locations sheet. This may not be an issue for you - for instance, if another set of code builds the email list - but could be something to think about.

Upvotes: 1

Related Questions