VBA code to automatically send several different emails (body different) based on cell data

S

Schanemans

New Member
Joined
May 11, 2021
Messages
1
Office Version
  1. 2013
Platform
  1. Windows
Hello, I have been trying to do a VBA code that will send a different email for certain workbook sheets. For example I have 6 sheets and when I open the workbook I want it to send the email for each tab automatically based on cell data. The body of the emails are all different. I am having trouble finding a code for this. Can some please help? I have included a sample of my spreadsheet. I have the code currently in ThisWorkbook. I have tried it in the sheets individually, a call code, loop but I need it to have the different emails that are specific to the corresponding sheets-See VBA code at bottom (the email body is different on each one). I only need 4 of the sheets to send emails. It won't send any emails. But does if I just do 1 code on 1 sheet only.
Pasted copy of workbook:
1620868233390.png

Mini Sheets in order:
1-
Test Test2.xlsm
ABCDFGMNOPQR
5StatusAgency/Owner/LinkTypeAgreement Title/Project NameBegin DateTerm/ExpStaff Contact First NameStaff Contact Last NameStaff EmailReminder SentWas Reminder SentDate To Send Reminder
6ActivePuget Sound Council of GovernmentsInterlocal AgreementInterlocal Cooperation Act of 19675/12/1977On GoingTooOldoldt@cobl.us 
7InactiveErickson Short PlatAgreementWater & Sewer Developer Agreement for Erickson Short Plat 194th & 75 SE SP#96-78/28/19984/11/2021TooOldoldt@cobl.us3/12/2021
Agreements ACTIVE
Cell Formulas
RangeFormula
A6:A7A6=IF(G6<$H$1,"Inactive",("Active"))
O6:O7O6=IF((OR(M6="",N6="")),"",HYPERLINK(LOWER(N6&LEFT(M6,1))&"@cobl.us"))
R6:R7R6=IF((OR(G6="Unknown",G6="On Going",G6="Auto-Renewing",G6="Until Annexed",G6="Until Complete",G6="Upon Completion",G6="",G6="Life of property",G6="Annually")),"",G6-$I$1)

2-
Test Test2.xlsm
ABCDFGMNOPQR
5StatusAgency/Owner/LinkTypeAgreement Title/Project NameBegin DateTerm/ExpStaff Contact First NameStaff Contact Last NameStaff EmailReminder SentWas Reminder SentDate To Send Reminder
6ActiveAstound BroadbandFranchise AgreementTelecommunications Franchise for Broadband internet (wave) - Ord 15403/15/20163/15/2031TooOldoldt@cobl.us2/13/2031
7InactiveAstound BroadbandFranchise AgreementTelecommunications Franchise for Broadband internet (wave) - Ord 15403/15/20164/11/2021TooOldoldt@cobl.us3/12/2021
Franchise Agreements ACTIVE
Cell Formulas
RangeFormula
A6:A7A6=IF(G6<$H$1,"Inactive",("Active"))
O6:O7O6=IF((OR(M6="",N6="")),"",HYPERLINK(LOWER(N6&LEFT(M6,1))&"@cobl.us"))
R6:R7R6=IF((OR(G6="Unknown",G6="On Going",G6="Auto-Renewing",G6="Until Annexed",G6="Until Complete",G6="Upon Completion",G6="",G6="Life of property",G6="Annually")),"",G6-$I$1)

3-
Test Test2.xlsm
ABCDFG
5StatusAgency/OwnerTypeAgreement Title/Project NameBegin DateTerm/Exp
6InactiveFank Coluccio Construction Co.AgreementLake Tapps Sewerage Project Ineterceptors Phase I (Contract S79-1) - Schedule A8/27/19796/3/1905
7InactiveTucci & Sons, Inc.AgreementLake Tapps Sewerage Project Ineterceptors Phase I (Contract S79-1) - Schedule B & C8/27/19796/3/1905
Agreements INACTIVE
Cell Formulas
RangeFormula
A6:A7A6=IF(G6<$H$1,"Inactive",("Active"))

4-
Test Test2.xlsm
ABCDFJKLQRSTUV
5StatusContractor/Owner/PrincipalProject Name/TitleProject TypeBond TypeStart DateExpire DateRelease DateStaff Contact First NameStaff Contact Last NameStaff EmailReminder SentWas Reminder SentDate To Send Reminder
6ActiveCascade RCL, LLC Stream Mitigation PlantingDeveloperAssignment of Funds12/18/2018Until ReleasedTooOldoldt@cobl.us 
7EXPIREDMulti SystemWetland RequirementCityDeveloper's Maintenance Bond11/11/20194/11/2021TooOldoldt@cobl.us4/11/2021
BONDS & Assign Funds ACTIVE
Cell Formulas
RangeFormula
A6:A7A6=IF(K6<$H$1,"EXPIRED",("Active"))
S6:S7S6=IF((OR(Q6="",R6="")),"",HYPERLINK(LOWER(R6&LEFT(Q6,1))&"@cobl.us"))
V6:V7V6=IF((OR(K6="Until Released",K6="1 year after completion",K6="2 years after completion")),"",K6-$I$1)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D7:E7Cell Valuecontains "City"textYES
D7:E7Cell Valuecontains "Develop"textYES
D8:E64401,D5:E6Cell Valuecontains "City"textYES
D8:E64401,D5:E6Cell Valuecontains "Develop"textYES
A5:A64401Cell Value="ACTIVE"textYES
A5:A64401Cell Value="Inactive"textYES
Cells with Data Validation
CellAllowCriteria
J5:J64401Any value
K5Any value
L5Any value
K6:L64401Any value
A5:A7Any value

5-
Test Test2.xlsm
ABDHIK
5StatusContractor/Owner/PrincipalBond TypeStart DateExp/Release DateLocation of Original Copy
6ActiveAsphalt Patch Systems, INCStreet Restoration Bond8/14/2019Continuous Until CanceledPermitting Book
7EXPIREDEagle Asphalt Selcoating Co., LLCStreet Restoration Bond5/2/20205/2/2021Permitting Book
ROW BONDS
Cell Formulas
RangeFormula
A6:A7A6=IF(I6<$G$2,"EXPIRED",("Active"))
Cells with Conditional Formatting
CellConditionCell FormatStop If True
D6:E7Cell Valuecontains "City"textYES
D6:E7Cell Valuecontains "Develop"textYES
D5:E5,D8:E65054Cell Valuecontains "City"textYES
D5:E5,D8:E65054Cell Valuecontains "Develop"textYES
A47,C48:C53,A54:A60,A62:A65055,A5:A8Cell Value="ACTIVE"textYES
A47,C48:C53,A54:A60,A62:A65055,A5:A8Cell Value="Inactive"textYES
Cells with Data Validation
CellAllowCriteria
A5:A7Any value
H5:H47Any value
I5:I47Any value

6-
Test Test2.xlsm
ABCFJKLQRSTUV
5StatusContractor/Owner/PrincipalProject Name/TitleBond TypeStart DateExpiration DateDate ReleasedStaff Contact First NameStaff Contact Last NameStaff EmailReminder SentWas Reminder SentDate To Send Reminder
6DestroyedS & S ConstructionWater Mains Contract 70-1Performance Bond3/13/197012/31/198012/31/1980TooOldoldt@cobl.us 
7ExpiredClements & Son1990 City Hall RemodelPerformance Bond11/20/19904/12/1991TooOldoldt@cobl.us4/12/1991
BONDS & Assign Funds Inactive
Cell Formulas
RangeFormula
S6:S7S6=IF((OR(Q6="",R6="")),"",HYPERLINK(LOWER(R6&LEFT(Q6,1))&"@cobl.us"))
V6:V7V6=IF((OR(A6="",A6="Released",A6="N/A",A6="Destroyed")),"",K6-$I$1)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
A4617:A64838,A5:A7Cell Value="ACTIVE"textYES
A4617:A64838,A5:A7Cell Value="Inactive"textYES
Cells with Data Validation
CellAllowCriteria
A5:A7Any value
J5:J7Any value
K5:K7Any value
L5Any value
L6:L7Any value




VBA Code: 
Sub NewMac()
'change macro names to suit
Dim ws As Worksheet
   
   '** SET The Sheet Names - MUST Reflect Each Sheet Name Exactly!
   WkSheets = Array("Agreements ACTIVE", "Franchise Agreements ACTIVE", "Bonds & Assign Funds ACTIVE", "Bonds & Assign Funds Inactive")
   
   For Each ws In Sheets(Array("Agreements ACTIVE", "Franchise Agreements ACTIVE", "Bonds & Assign Funds ACTIVE", "Bonds & Assign Funds Inactive"))
   ws.Select.Activate
Call AgreementsActive
   Next ws
Call FranchiseAgreements
   Next ws
Call BondsActive
   Next ws
Call BondsInactive
Next ws
End Sub

Public Sub AgreementsActive()
 
 
 Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
  
    
    For i = 6 To Range("R65536").End(xlUp).Row
        If Cells(i, 17) <> "Y" Then
            If Cells(i, 18) <= Date Then
                Set OutMail = OutApp.CreateItem(0)
                strto = Cells(i, 15).Value 'email address
                strsub = Cells(i, 4).Value & " will expire on " & Cells(i, 7).Value 'email subject
                strbody = "Hello " & Cells(i, 13).Value & vbNewLine & "The " & Cells(i, 3).Value & " for the " & Cells(i, 4).Value & " will be expiring on " & Cells(i, 7).Value & ", please review it on the agreements log at:" & vbNewLine & "N:\Everyone\CONTRACTING\Agreements-Bonds LogNEW- the agreements active tab at bottom" & vbNewLine & "to see if it needs to be renewed and place any notes in column H, please." & vbNewLine & "Then if it needs to be renewed, please start the process." & vbNewLine & "Thank you" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    .SentOnBehalfOfName = "[I]my email[/I]"
                    .Send
                                                                       
                End With
                On Error Resume Next
                Cells(i, 16) = "Mail Sent " & Now()
                Cells(i, 17) = "Y"
                
            End If
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
 End Sub
 
Public Sub FranchiseAgreements()
    
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
        
    
    For i = 6 To Range("R65536").End(xlUp).Row
        If Cells(i, 17) <> "Y" Then
            If Cells(i, 18) <= Date Then
                Set OutMail = OutApp.CreateItem(0)
                strto = Cells(i, 15).Value 'email address
                strsub = Cells(i, 4).Value & " will expire on " & Cells(i, 7).Value 'email subject
                strbody = "Hello " & Cells(i, 13).Value & vbNewLine & "The " & Cells(i, 3).Value & " for the " & Cells(i, 4).Value & " will be expiring on " & Cells(i, 7).Value & ", please review it on the agreements log at:" & vbNewLine & "N:\Everyone\CONTRACTING\Agreements-Bonds LogNEW- the franchise active tab at bottom" & vbNewLine & "to see if it needs to be renewed and place any notes in column H, please." & vbNewLine & "Then if it needs to be renewed, please start the process." & vbNewLine & "Thank you" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    .SentOnBehalfOfName = "[I]my email[/I]"
                    .Send
                    
                                    
                End With
                On Error Resume Next
                Cells(i, 16) = "Mail Sent " & Now()
                Cells(i, 17) = "Y"
                
            End If
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Public Sub BondsActive()
    
    
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
        
    
    For i = 6 To Range("V65536").End(xlUp).Row
        If Cells(i, 21) <> "Y" Then
            If Cells(i, 22) <= Date Then
                Set OutMail = OutApp.CreateItem(0)
                strto = Cells(i, 19).Value 'email address
                strsub = Cells(i, 3).Value & " bond expired on " & Cells(i, 11).Value 'email subject
                strbody = "Hello " & Cells(i, 17).Value & vbNewLine & "The " & Cells(i, 6).Value & " for the " & Cells(i, 3).Value & " expired on " & Cells(i, 11).Value & ", please review it on the bonds log at:" & vbNewLine & "N:\Everyone\CONTRACTING\Agreements-Bonds LogNEW- the Bonds & Assign Funds Active tab at bottom" & vbNewLine & "to write and send a release letter and place any notes in column M, please." & vbNewLine & "Then place the date the release letter was sent in column L and email the City Clerk's Office that you released the bond." & vbNewLine & "Thank you" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    .SentOnBehalfOfName = "[I]my email[/I]"
                    .Send
                    
                                    
                End With
                On Error Resume Next
                Cells(i, 20) = "Mail Sent " & Now()
                Cells(i, 21) = "Y"
                
            End If
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Public Sub BondsInactive()

    
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
        
    
    For i = 6 To Range("V65536").End(xlUp).Row
        If Cells(i, 21) <> "Y" Then
            If Cells(i, 22) <= Date Then
                Set OutMail = OutApp.CreateItem(0)
                strto = Cells(i, 19).Value 'email address
                strsub = Cells(i, 3).Value & " bond expired on " & Cells(i, 11).Value 'email subject
                strbody = "Hello " & Cells(i, 17).Value & vbNewLine & "The " & Cells(i, 6).Value & " for the " & Cells(i, 3).Value & " expired on " & Cells(i, 11).Value & " and no release date was entered." & vbNewLine & "Please review it on the bonds log at:" & vbNewLine & "N:\Everyone\CONTRACTING\Agreements-Bonds LogNEW- the Bonds & Assign Funds Active tab at bottom" & vbNewLine & "to review and write and send a release letter if needed and place any notes in column M, please." & vbNewLine & "Then place the date that the release letter was sent in column L and email the City Clerk's Office that you released the bond." & vbNewLine & "Thank you" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    .SentOnBehalfOfName = "[I]my email[/I]"
                    .Send
                    
                                    
                End With
                On Error Resume Next
                Cells(i, 20) = "Mail Sent " & Now()
                Cells(i, 21) = "Y"
                
            End If
        End If
    Next

Set OutMail = Nothing
Set OutApp = Nothing
End Sub[/CODE]
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA sending an email of two conditions are met
Replies
5
Views
137
mumps
mumps
H
  • Question Question
Macro to email Report
Replies
2
Views
549
howard
H
S
  • Solved
Tweak to VBA email code
Replies
3
Views
757
rollis13
rollis13
T
  • Solved
VBA HTML email formatting
Replies
2
Views
319
Micron
M
The Ruff Report
  • Question Question
Help adjusting Macro to email multiple cc addresses
Replies
1
Views
885
The Ruff Report
The Ruff Report

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top