VBA - Sending a single email with all entries to multiple recipents

[kakdativikam]

Hi,

First and foremost, I'd like to state that I'm an absolute beginner when it comes to VBA. As the title says - I've got myself onto a journey to find and adapt a macro, which would take all rows from my table, for a single user and put them in an email, then send them in a bulk.

I have found the following VBA code that seems to cover all the requirements, but I'm getting a "Subscript out of range" error. When I debug the code, I get the following part highlighted: For counter = 0 To UBound(toArray).

Any guidance will be absolutely appreciated.

Option Explicit

Public Sub SendEmail()
    ' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    ' Working in Office 2000-2016
    ' Adapted by Ricardo Diaz ricardodiaz.co
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sourceTable As ListObject
    Dim evalRow As ListRow

    Dim counter As Long
    Dim toArray() As Variant

    Application.ScreenUpdating = False

    Set OutApp = CreateObject("Outlook.Application")

    Set sourceTable = Range("Table1").ListObject ' -> Set the table's name

    On Error GoTo cleanup


    ' Loop through each table's rows
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
            counter = counter + 1
        End If

    Next evalRow

    ' Setup the email
    Set OutMail = OutApp.CreateItem(0)


    With OutMail
        ' Add gathered recipients
        For counter = 0 To UBound(toArray)
            .Recipients.Add (toArray(counter))
        Next counter

        .Subject = "Reminder"

        .Body = "Dear All" _
                & vbNewLine & vbNewLine & _
                "Please contact us to discuss bringing " & _
                "your account up to date"

        'You can add files also like this
        .Attachments.Add ("C:\test.txt") ' -> Adjust this path

        .Send ' -> Or use Display
    End With

    Set OutMail = Nothing

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Thanks in advance.

 

[LMacD]

The Ubound(toArray) needs to yield a number so your loop will work.
If toarray is not DIMed then Ubound(toarray) will result in an error.

If this if statement is false

If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then

then toArray will not be DIMed and the error will be "Subscript out of range"

Put a Breakpoint on the if statement and then press F8. If it does not execute the DIM statement that is your problem.

 

[kakdativikam]

The Ubound(toArray) needs to yield a number so your loop will work.
If toarray is not DIMed then Ubound(toarray) will result in an error.

If this if statement is false

If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then

then toArray will not be DIMed and the error will be "Subscript out of range"

Put a Breakpoint on the if statement and then press F8. If it does not execute the DIM statement that is your problem.

Hi Mac,

Thanks for the response. When I put a breakpoint and run the code with F8, the IF is executed and then it goes straight to End If, so I guess that confirms it's the IF being at fault.

My 3rd column consists of email addresses and the 6th one has the status (Finished/Not Finished). I'm a slow learner in coding, so I don't know what should I be looking at next. Further guidance will be much appreciated.

 

[kakdativikam]

Hi,

I found the issue. It was the LCase on this line -

LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then

Thanks a lot for the guidance, Mac.

 

[LMacD]

Suggestion" add a few lines to handle the error if it occurs

    ' Loop through each table's rows
    counter = -1   'set count to -1
    For Each evalRow In sourceTable.ListRows

        If evalRow.Range.Cells(, 2).Value Like "?*@?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
            counter = counter + 1 ' I moved this line so counter is incremented before the REDIM
            ReDim Preserve toArray(counter)
            toArray(counter) = evalRow.Range.Cells(, 2).Value
        End If

    Next evalRow

    'Now I can do a test to make sure I have at least one email in the array
    'If not I exit with an error on UBound
    If counter = -1 Then
        MsgBox "There are no email address in the array"
        Exit Sub
    End If

  ' Setup the email
    Set OutMail = OutApp.CreateItem(0)