Email Range of Cells Based on Multiple Conditions

[zacheria77]

Hello,I'm new to VBA and am having difficulties email a range of cells based on a set of conditions. I am trying to modify the code that I found here https://www.rondebruin.nl/win/s1/outlook/bmail2.htm to do the following: (1) Only include rows returning a "Yes" value in Column Y, (2) Only include rows which have a matching value in Column I, and (3) Hide all columns except C, D, G, S, and T. Column Y returns a "Yes" if the condition for a reminder have been met and Column I includes the intended recipient. I want each recipient to include one email for every row which meets the condition in Column Y. The code works as designed I am just unable to modify the range to allow for my conditions. As modified, it emails the entire table and then hides certain columns in the source sheet. Copy of the modified code: Sub LateReviewEmail_Click() Dim OutApp As Object, OutMail As Object Dim rng As Range Dim StrBody As String StrBody = "" & _ "Hello,

" & _ "This is a reminder that the following deliverables are pending your review:
" StrBody1 = "
Please complete your review and submit back to the Deliverable Monitor with your recommendation as soon as possible." & _ "

Regards," & _ "

" & _ "

Contract Management" & _ Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application") LastRow = Cells(Cells.Rows.Count, "Y").End(xlUp).Row On Error Resume Next Set rng = Sheets("Deliverable Management").Range("B4:AB" & LastRow).SpecialCells(xlCellTypeVisible) If Cells(Cell.Row, "Y").value = "No" Then _ EntireRow.Hidden = True Range("B5,E5,F5,H5,I5,J5,K5,L5,M5,N5,O5,P5,Q5,R5,V5,W5,X5,Y5,Z5,AA5,AB5").EntireColumn.Hidden = True On Error GoTo cleanup Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = "" .CC = "" .Subject = "Late Review" .Importance = olImportanceHigh .HTMLBody = StrBody & RangetoHTML(rng) & StrBody1 .SentOnBehalfofName = "" .Display End With On Error GoTo 0 Set OutMail = Nothingcleanup: Set OutApp = Nothing Application.ScreenUpdating = TrueEnd Sub

 

[AFPathfinder]

Welcome to the forums and VBA!

For future posting, make sure you use CODE tags to post VBA code; helps us read and work on what you submit.

Here are some of the changes I made:

• The main ingredient you seem to be missing is a loop. The loop will allow the macro to go row by row, check for a "Yes" in column Y, and generating an email for that row if it's true.
• I took out all the error handling lines. You shouldn't need them as long as you have MS Outlook desktop application installed and the Outlook library reference enabled.
• I added in "vbNewLine" in your string variables to provide the carriage returns. The underscores only provide line extensions in the VB Editor.
• I moved the hidden columns line below the loop.

Give this a whirl and see if it works or needs a few more tweaks.

Sub LateReviewEmail_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim StrBody As String
    Dim StrBody1 As String
    Dim i As Integer
    Dim lastRow As Integer
    
    StrBody = "Hello," & vbNewLine & "This is a reminder that the following deliverables are pending your review: "
    StrBody1 = "Please complete your review and submit back to the Deliverable Monitor with your recommendation as soon as possible." _
        & vbNewLine & vbNewLine & "Regards, " & vbNewLine & vbNewLine & "Contract Management"
    Application.ScreenUpdating = False
    
    Set OutApp = CreateObject("Outlook.Application")
    
    lastRow = Cells(Cells.Rows.Count, "Y").End(xlUp).Row
    
    For i = 2 To lastRow
        Set OutMail = OutApp.CreateItem(0)
        
        If Cells(i, "Y").Value = "Yes" Then
            With OutMail
                .To = Cells(i, "I").Value
                .CC = ""
                .Subject = "Late Review"
                .Importance = olImportanceHigh
                .HTMLBody = StrBody & StrBody1
                .Display
            End With
        End If
        
        Set OutMail = Nothing
    Next i
    
    Set OutApp = Nothing

    Range("A1:B1, E1:F1, H1:R1, U1:AB1").EntireColumn.Hidden = True
    
    Application.ScreenUpdating = True
End Sub