Help converting single recipient email macro to limitless

Hi taylorsm

Perhaps a loop referencing an range of cells with the email addresses...something like this:

Dim LastRow As Long
Dim i As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow 'First email address starts in A2
    'Not to sure what email service you are using
    With ActiveSheet.MailEnvelope
        .Introduction = "Production Report."
        .Item.To = ActiveSheet.Range("A" & i).Value
        .Item.Subject = Format(Now, "mm-dd-yy ") & "Production Report"
    End With
Next i

Let try this method: Code prompts user to select the file to open, then assuming that email addresses are stored in Column A, loops and sends email to each address found in col A...This is for Outlook 2007

Option Explicit
Sub SendEmail()
Dim EmailSubject As String
Dim Email_To As String, Email_CC As String, Email_BCC As String, Email_Body As String
Dim DisplayEmail As Boolean
Dim OutlookApp As Object, OutlookMail As Object
Application.ScreenUpdating = False
Dim LastRow As Long
Dim i As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim fNameAndPath As Variant
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow 'First email address starts in A1
    EmailSubject = "This is a test"
    DisplayEmail = True
    Email_To = StrConv(ActiveSheet.Range("A" & i), vbLowerCase)
    Email_Body = "Good afternoon"
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject
        '.HTMLBody = Sp & Email_Body & .HTMLBody
        '.Attachments.Add PDFFile
        If DisplayEmail = False Then
        .Send
        End If
    End With
Next i
Application.ScreenUpdating = True
wb.Close savechanges:=True 'or false
End Sub

Not to sure taylorsm...Can only test to find out.

Yep that's right...Was just a test.You will have to edit to add your Subject, body etc.

Option Explicit
Sub Auto_Open()
Dim EmailSubject As String
Dim Email_To As String, Email_CC As String, Email_BCC As String, Email_Body As String
Dim DisplayEmail As Boolean
Dim OutlookApp As Object, OutlookMail As Object
Application.ScreenUpdating = False
Dim LastRow As Long
Dim i As Integer
Dim ws As Worksheet
Dim wb As Workbook
Dim fNameAndPath As Variant
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel Files (*.XLSX), *.XLSX", Title:="Select File To Be Opened")
If fNameAndPath = False Then Exit Sub
Set wb = Workbooks.Open(fNameAndPath)
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow 'First email address starts in A1
    EmailSubject = "This is the information pertaining to your subject" ' Or it can be a reference to a Range
    DisplayEmail = True
    Email_To = StrConv(ActiveSheet.Range("A" & i), vbLowerCase)
    Email_Body = "This is where you put in your information pertaining to your email body"
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .Display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject
        .HTMLBody = Sp & Email_Body & .HTMLBody
        '.Attachments.Add PDFFile' Here you can add any attachments ...Just remove the "'" Character
        If DisplayEmail = False Then
        .Send
        End If
    End With
Next i
Application.ScreenUpdating = True
wb.Close savechanges:=True 'or false
End Sub