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
Central Kivell
Central Jardine
Central Gill
West Sorvino
East Jones
Central Andrews
Central Jardine
West Thompson
East Jones
Central Morgan
East Howard
East Parent
East Jones
Central Smith
East Jones
Central Morgan
East Jones

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


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

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 = “”
.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. 
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