Excel 2021 VBA - Email from filtered table

[BrerRabbit]

I'm able to email to the email addresses from an unfiltered table, but not from a filtered table.

How do I change this code so that I email ONLY to the filtered email addresses?

Thank you in advance for your help.

Do While intCountRow <= intRowstoCount

strEmailTo = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(intCountRow, intColumnNo).Text

'With ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS")
' For Each rngFilteredRecipient In .Range("AP35:AP" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Cells

If strEmailTo = "0" Then

Else

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strEmailTo = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(intCountRow, intColumnNo).Text
strSubject = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(15, 5).Text

 

[Domenic]

I haven't tested it, but see if the following helps...

Option Explicit

Sub SendEmailsForFilteredRecipients()

    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS")
  
    Dim lastRow As Long
    With sourceWorksheet
        lastRow = .Cells(.Rows.Count, "AP").End(xlUp).Row
    End With
  
    If lastRow < 35 Then
        MsgBox "No data found!", vbExclamation
        Set sourceWorksheet = Nothing
        Exit Sub
    End If
  
    On Error Resume Next
    Dim filteredRange As Range
    Set filteredRange = sourceWorksheet.Range("AP35:AP" & lastRow)
    If filteredRange Is Nothing Then
        MsgBox "No filtered data found!", vbExclamation
        Set sourceWorksheet = Nothing
        Exit Sub
    End If
    On Error GoTo 0
  
    Dim strSubject As String
    strSubject = sourceWorksheet.Cells(15, 5).Text
  
    Dim OutApp As Object
    Set OutApp = CreateObject("Outlook.Application")
  
    Dim OutMail As Object
    Dim currentCell As Range
    Dim strEmailTo As String
    For Each currentCell In filteredRange
        strEmailTo = currentCell.Text
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = strEmailTo
            .Subject = strSubject
            .body = "Your text here..."
            .display '.Send
        End With
    Next currentCell
  
    Set filteredRange = Nothing
    Set sourceWorksheet = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Note, as it stands, the code displays the emails instead of sending them out. Once you've tested it and you're satisfied with it, you can replace .display with .send to actually send them out.

Hope this helps!

 

[BrerRabbit]

My apologies for the late reply.

I can't get this code to work. It definitely doesn't like the:

With wkstPRE
lngLastRow = .Cells(.Rows.Count, intColumn).End(xlUp).Row
End With

code. .Rows is giving this 1004 error.
I did omit that I'm using one code to differentiate between sending emails based on 5 different reports, therefore a select case is in play. I apologise. The filtered is only apply to R1.

This is my code in full. I know some VB code but not all. I definitely don't know how to do finding emails on filtered rows. Thank you in advance.

Private Sub cmdSendEmail_Click()

Dim OutApp As Object
Dim OutMail As Object
Dim strClassorRegion As String
Dim str0Email As String
Dim strEmailTo As String
Dim strPictureTop As String
Dim strBody As String
Dim strSubject As String
Dim strAtt1 As String
Dim strAtt2 As String
Dim strAtt3 As String
Dim intTotalRowCount As Integer
Dim intRowstoCount As Integer
Dim intRowNo As Integer
Dim intColNo As Integer
Dim intPicHeight As Integer
Dim intCountRow As Integer
Dim intCountColumn As Integer
Dim intCountBlank As Integer
Dim intRowTotal As Integer
Dim resp As Integer
Dim intNoofEmailAddresses As Integer
Dim strReportType As String
Dim rngFilteredRecipient As Range
Dim intColumn As Integer

Dim wkstPRE As Worksheet
Dim lngLastRow As Long
Set wkstPRE = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS")

intTotalRowCount = 196
intCountColumn = 29
intCountRow = 36
intRowstoCount = 0

Select Case Range("B12").Value

Case "R1"
intColumnNo = 42
With wkstPRE
lngLastRow = .Cells(.Rows.Count, intColumn).End(xlUp).Row
End With
'lngLastRow = wkstPRE.Cells(.Rows.Count, intColumn).End(xlUp).Row
'intCountBlank = WorksheetFunction.CountBlank(Range("AL36:AL231"))
strReportType = Range("AL32").Value
Case "R2"
intColumnNo = 51
intCountBlank = WorksheetFunction.CountBlank(Range("AV36:AV231"))
strReportType = Range("AV32").Value
Case "R3"
intColumnNo = 71
intCountBlank = WorksheetFunction.CountBlank(Range("BO36:BO231"))
strReportType = "No Class Attendance Over 3 Months"
Case "R4"
intColumnNo = 79
intCountBlank = WorksheetFunction.CountBlank(Range("BW36:BW231"))
strReportType = "No Class Attendance"
Case "R5"
intColumnNo = 60
intCountBlank = WorksheetFunction.CountBlank(Range("BE36:BE231"))
strReportType = Range("BE32").Value
End Select

intRowTotal = intTotalRowCount - intCountBlank
intRowstoCount = intTotalRowCount - intCountBlank + 36
intNoofEmailAddresses = Range("B10").Value

resp = MsgBox("Have you checked your email via the Test Email button? Are you sure you want to send these emails? There are " & intNoofEmailAddresses & _
" emails of " & intRowTotal & " participants that will be sent." & Chr(13) & Chr(13) & "OK to continue. Cancel to Exit.", vbOKCancel, strReportType & " Report. " & intNoofEmailAddresses & " emails.")

Select Case resp
Case 1

Case 2
'Application.ScreenUpdating = True
End 'Exit Sub
End Select

Do While intCountRow <= intRowstoCount

strEmailTo = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(intCountRow, intColumnNo).Text

'With ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS")
' For Each rngFilteredRecipient In .Range("AP35:AP" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Cells

If strEmailTo = "0" Then

Else

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strEmailTo = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(intCountRow, intColumnNo).Text
strSubject = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(15, 5).Text
'strPictureTop = ThisWorkbook.Sheets("REPORTS & EMAILS").Cells(3, 8).Text
'intPicHeight = ThisWorkbook.Sheets("REPORTS & EMAILS").Cells(3, 8).
strBody = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(17, 7).Text
strAtt1 = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(26, 4).Text
strAtt2 = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(27, 4).Text
strAtt3 = ThisWorkbook.Sheets("PARTICIPANT REPORTS & EMAILS").Cells(28, 4).Text

On Error Resume Next
With OutMail
.To = strEmailTo
.Subject = strSubject
.Display
'.HTMLBody = "<img src='" & strPictureTop & "' height='10%'>" & "<br>" & strBody & .HTMLBody
.HTMLBody = strBody & .HTMLBody
.attachments.Add strAtt1
.attachments.Add strAtt2
.attachments.Add strAtt3
'.Send 'will send if not commented out

End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End If
intCountRow = intCountRow + 1

Loop
'Excel VBA Macro: Send Multiple Emails (Based on Cell Values with Loop)
'

End Sub

 

[MARK858]

I can't get this code to work. It definitely doesn't like the:

With wkstPRE
lngLastRow = .Cells(.Rows.Count, intColumn).End(xlUp).Row
End With

You haven't set a value to intColumn, you have a variable called intColumnNo that you have set a value to (but haven't declared).

What actually happened with the code @Domenic gave you.

P.S. please wrap your code in code tags in future as not doing so makes your code very difficult to read