VBA Macro Project A
Creation to Completion : 1 month
I developed a VBA macro to automate the creation and circulation of DIN letters for utility notifications, a process that previously required manually populating templates and sending each email individually. Each year, around 300 emails were sent, taking roughly 35 hours of repetitive work. The macro compiles project data, populates Word templates, exports PDFs, and generates draft emails with customized subjects and attachments in Outlook, eliminating manual data entry and ensuring consistency. This tool significantly reduces administrative workload, allowing the team to focus on design and coordination while saving dozens of hours annually.
Sub compile_worktype()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim worktype As String
Dim dummytext As String
dummytest = ""
worktype = ""
i = 0
j = 0
k = 1
Do While Worksheets("Projects").Range("C2").Offset(i, 0).Value <> ""
' Worksheets("Projects").Range("C2").Offset(i, 8).Value = ""
i = i + 1
Loop
i = 0
Do While Worksheets("Projects").Range("C2").Offset(i, 0).Value <> ""
Do While j < 9
If Worksheets("Projects").Range("C2").Offset(i, j).Value = "" Or j = 9 Then
' next type
j = j + 1
ElseIf Worksheets("Projects").Range("C2").Offset(i, j).Value <> "" Then
If worktype = "" Then
' first value
worktype = Worksheets("Projects").Range("C2").Offset(i, j).Value
j = j + 1
Else
Do While j + k < 9
' looking for last value
If Worksheets("Projects").Range("C2").Offset(i, j + k).Value <> "" Then
dummytext = dummytext + Worksheets("Projects").Range("C2").Offset(i, j + k).Value
' if dummytext is not empty, then its not the last value
k = k + 1
End If
k = k + 1
Loop
k = 1
If dummytext = "" Then
worktype = worktype & " and " & Worksheets("Projects").Range("C2").Offset(i, j).Value
j = j + 1
Else
worktype = worktype & ", " & Worksheets("Projects").Range("C2").Offset(i, j).Value
j = j + 1
End If
dummytext = ""
End If
End If
Loop
dummytext = ""
Worksheets("Projects").Range("C2").Offset(i, 8).Value = worktype
worktype = ""
i = i + 1
j = 0
k = 1
Loop
End Sub
Sub pop_template(TemplateLocation As String)
' load template
' Dim TemplateLocation As String
On Error Resume Next
' TemplateLocation = "C:\Documents and Settings\syue\Desktop\b\2.docx"
Dim wTApp As Word.Application
Dim wTDoc As Word.Document
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim p As Integer
Dim filename As String
Dim StartCell As String
Dim cc As ContentControl
Dim docCCs As ContentControls
Dim ccTag As String
i = 2
j = 2
k = 1
p = 1
Set wTApp = CreateObject("Word.Application")
wTApp.Visible = False
Set wTDoc = wTApp.Documents.Open(TemplateLocation)
' populate template
Do While Worksheets("Contacts").Cells(i, 1).Value <> ""
Do While Worksheets("Projects").Cells(j, 1).Value <> ""
' ====================================================================================
Do While k <= wTDoc.ContentControls.Count
If wTDoc.ContentControls(k).Tag = "PIN_Date" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Format(Date, "mmmm, d yyyy"))
ElseIf wTDoc.ContentControls(k).Tag = "PIN_recipient" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 2).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Address1" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 6).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Address2" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 7).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Address3" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 8).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Email" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 4).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Company" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Contacts").Cells(i, 1).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Plan" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Projects").Cells(j, 14).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Worktype" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Projects").Cells(j, 11).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_Location" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Worksheets("Projects").Cells(j, 2).Value)
ElseIf wTDoc.ContentControls(k).Tag = "PIN_TenderMonth" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Format(Worksheets("Projects").Cells(j, 12).Value, "mmmm, d yyyy"))
ElseIf wTDoc.ContentControls(k).Tag = "PIN_ConstructionMonth" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Format(Worksheets("Projects").Cells(j, 13).Value, "mmmm, d yyyy"))
ElseIf wTDoc.ContentControls(k).Tag = "PIN_ResponseDate" Then
Call wTDoc.ContentControls(k).SetPlaceholderText(, , Format(Date + 21, "mmmm d yyyy"))
End If
k = k + 1
Loop
k = 1
Do While p < wTDoc.ContentControls.Count + 1
If p > wTDoc.ContentControls.Count Then
'nothing
ElseIf wTDoc.ContentControls(p).Tag = "PIN_Date" Or _
wTDoc.ContentControls(p).Tag = "PIN_Company" Or _
wTDoc.ContentControls(p).Tag = "PIN_Address" Or _
wTDoc.ContentControls(p).Tag = "PIN_Email" Or _
wTDoc.ContentControls(p).Tag = "PIN_recipient" Then
With wTDoc.ContentControls(p).Range.Font
.Name = "calibri"
.Size = 11
.Color = wdColorBlack
End With
Else
With wTDoc.ContentControls(p).Range.Font
.Name = "calibri"
.Size = 11
.Color = wdColorBlack
.Bold = True
.Underline = wdUnderlineSingle
End With
End If
p = p + 1
Loop
p = 1
filename = "DIN for " & Worksheets("Contacts").Cells(i, 1).Value & " re " & Worksheets("Projects").Cells(j, 2).Value
wTDoc.ExportAsFixedFormat OutputFileName:=wTDoc.Path & "\" & filename & ".pdf", ExportFormat:=17
j = j + 1
Loop
j = 2
i = i + 1
Loop
Set wTApp = Nothing
Set wTDoc = Nothing
End Sub
The compile_worktype macro automatically consolidates multiple work types listed across columns in the Projects sheet into a single, readable string for each project, ensuring that each DIN letter accurately reflects all relevant work. The pop_template macro then takes this data along with contact information, opens a Word DIN letter template, populates all placeholders (like date, recipient, address, work type, and project details), applies consistent formatting, and exports each letter as a PDF. Together, these macros eliminate the manual, repetitive process of creating letters, ensure accuracy and formatting consistency, and save significant time in preparing documentation for utility circulation during the initial design phase.
Sub CreateDraftEmails_OneEmailPerPDF_WithCustomSubject()
Dim OutlookApp As Object, OutlookMail As Object
Dim ws As Worksheet
Dim i As Long
Dim pdfFolder As String, templatePath As String, companyName As String
Dim pdfFile As String, roadName As String, subjectText As String
' Paths
templatePath = "C:\Users\jlauan\Downloads\Justen Files\Utility Circulation\2027 CWP\DIN Road Name City of Toronto.oft"
pdfFolder = "C:\Users\jlauan\Downloads\Justen Files\Utility Circulation\2027 CWP\"
' Initialize Outlook
Set OutlookApp = CreateObject("Outlook.Application")
Set ws = ThisWorkbook.Sheets("Contacts")
i = 2
Do While ws.Cells(i, 1).Value <> ""
companyName = ws.Cells(i, 1).Value
' Find first matching PDF
pdfFile = Dir(pdfFolder & "DIN for " & companyName & "*.pdf")
If pdfFile = "" Then
MsgBox "No PDF found for " & companyName
Else
' Loop through all PDFs for this company
Do While pdfFile <> ""
' Extract road name from PDF filename
' Example filename: DIN for Bell Canada re Rampart Rd from Martin Grove Rd to cul-de-sac.pdf
If InStr(pdfFile, "re ") > 0 Then
roadName = Trim(Split(Mid(pdfFile, InStr(pdfFile, "re ") + 3), " from")(0))
Else
roadName = "Road Name" ' fallback if pattern not found
End If
' Build subject line
subjectText = "DIN – " & roadName & " – City of Toronto"
' Create email from template
Set OutlookMail = OutlookApp.CreateItemFromTemplate(templatePath)
With OutlookMail
.To = ws.Cells(i, 4).Value
.Subject = subjectText
.Attachments.Add pdfFolder & pdfFile
.Save ' Save to Drafts
End With
' Get next PDF
pdfFile = Dir()
Loop
End If
i = i + 1
Loop
MsgBox "Draft emails created successfully!"
End Sub
The CreateDraftEmails_OneEmailPerPDF_WithCustomSubject macro automates the creation of draft emails in Outlook for each PDF DIN letter, eliminating the need to manually attach files and write email subjects. It loops through all contacts in Excel, finds the corresponding PDF for each company, extracts the relevant road name from the filename to generate a clear, standardized subject line, and then creates an Outlook draft using a predefined email template with the PDF attached. This automation ensures consistency, reduces human error, and saves significant time when sending hundreds of utility circulation emails each year, allowing staff to focus on higher-value design and coordination tasks.
The CreateDraftEmails_OneEmailPerPDF
_WithCustomSubject macro automates the creation of draft emails in Outlook for each PDF DIN letter, eliminating the need to manually attach files and write email subjects. It loops through all contacts in Excel, finds the corresponding PDF for each company, extracts the relevant road name from the filename to generate a clear, standardized subject line, and then creates an Outlook draft using a predefined email template with the PDF attached. This automation ensures consistency, reduces human error, and saves significant time when sending hundreds of utility circulation emails each year, allowing staff to focus on higher-value design and coordination tasks.
