VBA Loop to send emails with 100 email addresses from list on each email

[picklechips]

Hi long time lurker 1st time poster.

I would like to send an outlook email to a list of email addresses in column A (first email address starts in cell a2). Each email should have 100 addresses in the "to", then another email creates with the next 100 addresses. Emails should create until until all addresses have been put into emails.

Below is what I have so far which opens an email and puts all the addressees from Column A into one email. I've looked through previous posts but could not figure out how to revise my "EmailTo" and using the "for/next" criterias

Thanks in advance all you ExcelMVPs!
Pickles

Option Explicit
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
  
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim Lastrw As Long
    
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'Get the text that will go on the subject
    subj = Sheets(1).Range("b2")


   'Get the text that will go on the body
    body = ActiveWorkbook.Sheets(1).Range("c2")
    
    'add signature
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    MsgBox SigString
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    Lastrw = Range("A" & Rows.Count).End(xlUp).Row
    
    EmailTo = Join(Application.Transpose(Sheets(1).Range("a2:a" & Lastrw).Value), ";")
    
        With OutMail
        .To = EmailTo
        .CC = ""
        .BCC = ""
        .subject = subj
       '.body = body
        .htmlbody = body & vbNewLine & vbNewLine & Signature
        .Attachments.Add Ratesheetpdf
        .Display
        '.send
    End With
    
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[Roderick_E]

rodericke.com/xlsuper MASSMAILER

 

[BiocideJ]

I believe this edit to your code will do what you are requiring.

Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
  
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim LastRw As Long
    
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    Set OutApp = CreateObject("Outlook.Application")


    
    'Get the text that will go on the subject
    subj = Sheets(1).Range("b2")




   'Get the text that will go on the body
    body = ActiveWorkbook.Sheets(1).Range("c2")
    
    'add signature
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    MsgBox SigString
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    
    LastRw = Range("A" & Rows.Count).End(xlUp).Row
    
    
    For i = 2 To LastRw Step 100

        EmailTo = Join(Application.Transpose(Sheets(1).Range("A" & i & ":A" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")

        Set OutMail = OutApp.CreateItem(0)
       With OutMail
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .Subject = subj
           '.body = body
            .htmlbody = body & vbNewLine & vbNewLine & Signature
            .Attachments.Add Ratesheetpdf
            .Display
            '.send
        End With
    
    Next i
    On Error GoTo 0


    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[picklechips]

I believe this edit to your code will do what you are requiring.

Thanks very much good sir! It worked perfectly after I added "dim i as integer" to the top.

The "step" is something I have been looking for over the last few days. Thanks again!

Pickles

 

[BiocideJ]

The "step" is something I have been looking for over the last few days. Thanks again!

Pickles

No problem. You had it 95% of the way there. STEP is one of those seldom used features in VBA, but it is quite useful given the right circumstances.