Been some days while I posted something, was busy with official tasks.

This came as a surprise when there was a need to send personalized emails to all new team members when a new team was formed. This is highly motivational and boosts morale.

We will start with basic data that we know of.

Team Rep email ID Lead
East Jones Jones@xyz.com Jones@xyz.com
Central Kivell Kivell@xyz.com Kivell@xyz.com
Central Jardine Jardine@xyz.com Kivell@xyz.com
Central Gill Gill@xyz.com Kivell@xyz.com
West Sorvino Sorvino@xyz.com Gill@xyz.com
East Jones Jones@xyz.com Jones@xyz.com
Central Andrews Andrews@xyz.com Kivell@xyz.com
Central Jardine Jardine@xyz.com Kivell@xyz.com
West Thompson Thompson@xyz.com Gill@xyz.com
East Jones Jones@xyz.com Jones@xyz.com
Central Morgan Morgan@xyz.com Kivell@xyz.com
East Howard Howard@xyz.com Jones@xyz.com
East Parent Parent@xyz.com Jones@xyz.com
East Jones Jones@xyz.com Jones@xyz.com
Central Smith Smith@xyz.com Kivell@xyz.com
East Jones Jones@xyz.com Jones@xyz.com
Central Morgan Morgan@xyz.com Kivell@xyz.com
East Jones Jones@xyz.com Jones@xyz.com

This is how the email should look like, Replace xxxx, yyyy with your message.

Capture

As you see in entire email, only 4 parameters change,

Name, Email id, Lead and team name and these are picked from table

Here is the code, See how this is closely related to other older posts.

Mailing Charts to different employees – VBA / Excel

Mail the Summary – VBA / Excel

‘————————————————————————————–

Sub Mail_From_ActiveRow()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Sourcews As Worksheet
Dim Mailwb As Workbook
Dim Mailws As Worksheet
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim ws As Worksheet
Dim wb As Workbook

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

Set Sourcewb = ActiveWorkbook
Set Sourcews = ActiveWorkbook.Worksheets(ActiveSheet.Name)

Name_Col = getColFromAddr(getAddress(Sourcews, “Rep”))
EmailID_Col = getColFromAddr(getAddress(Sourcews, “email ID”))
Team_Col = getColFromAddr(getAddress(Sourcews, “Team”))
Lead_Col = getColFromAddr(getAddress(Sourcews, “Lead”))

myrow = ActiveCell.Row

For Each wb In Application.Workbooks
For Each ws In wb.Worksheets

If ws.Name = “Mail” Then

Set Mailwb = wb
Set Mailws = ws
Exit For

End If

Next
Next
Range(“Salutation_Email”).Value = “Dear ” & Sourcews.Cells(myrow, Name_Col)
ToMailString = Sourcews.Cells(myrow, EmailID_Col)
CCMailString = Sourcews.Cells(myrow, Lead_Col)

SubJectString = Range(“Subject_Email”).Value

Range(“Team_Text”).Value = “I am extremely delighted to welcome you to the ” & Sourcews.Cells(myrow, Team_Col) & _
” team.”

Set rng = Sheets(“Mail”).Range(“Mail”).SpecialCells(xlCellTypeVisible)

Set OutApp = CreateObject(“Outlook.Application”)
Set OutMail = OutApp.CreateItem(0)
With Destwb
On Error Resume Next
With OutMail
‘.SentOnBehalfOfName = “iWFMCLR@csc.com”
.To = ToMailString
.CC = CCMailString
‘.BCC = “”
.Subject = SubJectString
‘.Body = “Hi there”
‘.Attachments.Add Destwb.FullName
.HTMLBody = RangetoHTML(rng)
‘You can add other files also like this
‘.Attachments.Add (“C:\test.txt”)
‘.Send ‘ when you have made mail completely and wnat to send instead of drating. 
.Display
End With
On Error GoTo 0

End With
ToMailString = “”
SubJectString = “”
CCMailString = “”

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

‘————————————————————————————–

 

If you run this macro this will make a draft mail from active cell, Now after you have modified the code to our liking, run this macro

‘————————————————————————————–

 

Sub Mail_Create()

‘For i = 2 To ActiveSheet.UsedRange.Rows.Count

For i = 2 To 10

If Not ActiveSheet.Cells(i, 1).EntireRow.Hidden Then
Range(“A” & i).Select

Call Mail_From_ActiveRow
End If
Next i

End Sub

‘————————————————————————————–

Here is the code and file to play with.

Make Team’s Mail

Cheers

CuriousJatin