CODEWITHSUNDEEP
excelvba
Nick
Nick

Reputation: 11

Improve process of taking email address from spreadsheet

I have a spreadsheet that I have set up to automatically pdf and email nightly based on email addresses I have listed out on a hidden worksheet. I currently have to dim seperate variable for each address and then specify which cell each variable equals. This works but I feel like there must be a better way to do this. Specifically, I would like to not have to add or delete dim'ed variables if I delete or add additional addresses to the list. Here is the code I am using:

Sub PDF_Email()


Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachment As Object
Dim MDir As String
Dim MName As String
Dim Address1 As String
Dim Address2 As String
Dim Address3 As String
Dim Address4 As String
Dim Address5 As String
Dim Address6 As String
Dim Address7 As String
Dim Address8 As String
Dim Address9 As String
Dim Address10 As String
Dim Address11 As String


Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set myAttachment = OutLookMailItem.Attachments

Address1 = Worksheets("EmailList").Cells(1, 1).Value
Address2 = Worksheets("EmailList").Cells(2, 1).Value


'Prevent Macro from running if different user
Const AllowedName As String = "nbelair"

If Environ("username") <> AllowedName Then
    Exit Sub
End If


MName = ActiveSheet.Name & " " & Format(Now() - 1, "dddd, mmmm, d, yyyy")
MDir = ActiveWorkbook.Path

ChDir "Y:\SMHC Management Team\Daily Labor Management\Dashboard\Archived 
Dashboards" 'Update to
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"Y:\SMHC Management Team\Daily Labor Management\Dashboard\Archived  
Dashboards\" & MName & ".pdf", OpenAfterPublish:=True 'Update



With OutLookMailItem
.To = Address1 & ";" & Address2
.Subject = "SMHC Daily Labor Management Dashboard - " & Format(Now() - 1, 
"dddd, mmmm, d, yyyy")
.Body = "Attached please find the SMHC Daily Labor Management Dashboard for 
" _
    & Format(Now() - 1, "dddd, mmmm, d, yyyy") & ".  You are receiving this 
email because you are currently " _
    & "on the distribution list for this report.  If you have any questions 
" _
    & "or concerns regarding this email or report please let me know by 
responding to this email or contacting me at 207 467 6983."

myAttachment.Add "Y:\SMHC Management Team\Daily Labor 
Management\Dashboard\Archived Dashboards\" & MName & ".pdf"
.Display
.Send
End With

'Clear Outlook Variables
Set OutLookMailItem = Nothing
Set OutLookApp = Nothing

'Quit
ThisWorkbook.Saved = True
Application.Quit

End Sub

Being new to coding, I would greatly appreciate any thoughts or suggestions someone might have. I am quickly falling in love with coding and welcome the chance to learn something new!

Thank You

Upvotes: 0

Views: 40

Answers (1)

urdearboy
urdearboy

Reputation: 14580

The first loop builds the string of To:

The second loop builds the string of CC:

Email addresses span column F for To and column G for CC

Dim i As Integer
Dim EmailTo As String
Dim EmailCC As String

For i = 2 To 30
    EmailTo = EmailTo & ThisWorkbook.Sheets("Email").Range("F" & i) & ";"
Next i

For i = 2 To 30
    EmailCC = EmailCC & ThisWorkbook.Sheets("Email").Range("G" & i) & ";"
Next i


ThisWorkbook.Sheets("Dash").Range("C2:Q63").Select
ThisWorkbook.EnvelopeVisible = True


    With ThisWorkbook.Sheets("Dash").MailEnvelope
        .Introduction = ""
        .Item.To = EmailTo
        .Item.CC = EmailCC
        .Item.Subject = "Subject " & Date
        .Item.Display
    End With

Upvotes: 1

Related Questions