Create And Send Multiple PDF Reports

Note: This webpage is designed to accompany the Youtube video posted above. The video offers detailed explanation on all topics; while this webpage will serve as a repository for the code presented in the video.

Each code block covered in the video is given below.

Main Macro

Option Explicit

Public Const sFilePath As String = "C:\Youtube\Current\02 Report Cards\Report Cards\"
Sub MainMacro()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim sCheckForFiles As String
sCheckForFiles = Dir(sFilePath & "*")

If sCheckForFiles <> "" Then
    MsgBox "Please empty folder before proceeding"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
End If

Dim sStudentID As String, sStudentName As String, sEmailId As String
Dim lrow As Long
lrow = wsStudents.Range("A1").CurrentRegion.Rows.Count

Dim i As Long

For i = 2 To lrow
    sStudentID = wsStudents.Range("A" & i).Value
    sStudentName = wsStudents.Range("B" & i).Value
    sEmailId = wsStudents.Range("C" & i).Value
    ' Clear Previous Values
    Call ClearData
    'Filter Student Data on Workings Sheet
    Call IsolateEachStudentData(sStudentID)
    'Populate Report Template
    Call PopulateIndvidualReport(sStudentID, sStudentName)
    'Save and Email Template
    Call CreateAndSendPDFCopy(sStudentID)
          
Next i

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

Clear Data

Option Explicit

Sub ClearData()

wsReport.Range("B8:B9").Value = ""
wsReport.Range("H8:H9").Value = ""
wsReport.Range("A13:H17").Value = ""
wsReport.Range("H20:H21").Value = ""

wsWork.Rows("2:" & Rows.Count).ClearContents

End Sub

Isolate Individual Student Data

Option Explicit

Sub IsolateEachStudentData(sStudentID As String)

''Testing
'Dim sStudentID As String
'sStudentID = "SK10005"

Dim rngList As Range, rngCopyTo As Range, rngCriteria As Range
Set rngList = wsMarks.Range("A1").CurrentRegion

wsWork.Range("A2").Value = sStudentID
Set rngCriteria = wsWork.Range("A1:A2")

Set rngCopyTo = wsWork.Range("D1:E1")

rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo, Unique:=False


End Sub

Populate Each Individual Report

Option Explicit

Sub PopulateIndvidualReport(sStudentID As String, sStudentName As String)

''Testing
'Dim sStudentID As String, sStudentName As String
'sStudentID = "SK10001"
'sStudentName = "Hamish T"

'Populate StudentID & Student Name
wsReport.Range("B8").Value = sStudentID
wsReport.Range("B9").Value = sStudentName

'Populate Student Marks
Dim lrow As Long
lrow = wsWork.Range("D1").CurrentRegion.Rows.Count
Dim i As Long
For i = 2 To lrow
    'Transfer Course Code
    wsReport.Range("D" & i + 11).Value = wsWork.Range("D" & i).Value
    'Transfer Marks
    wsReport.Range("F" & i + 11).Value = wsWork.Range("E" & i).Value
Next i

'Grab Course Name and Calculate Grades
Dim rngFind As Range
Dim sCourseID As String, sCourseName As String
Dim lMarks As Long
Dim lTotalUnits As Long, lAvgUnits As Long, sAvgGrade As String

For i = 13 To (13 + lrow - 1 - 1)
    'Grab Course Names
    sCourseID = wsReport.Range("D" & i).Value
    Set rngFind = wsCourse.Range("B:B").Find( _
                                        what:=sCourseID, LookIn:=xlValues)
    If Not rngFind Is Nothing Then
        sCourseName = rngFind.Offset(0, -1).Value
        wsReport.Range("A" & i).Value = sCourseName
    End If
    'Calculate Grades
    lMarks = wsReport.Range("F" & i).Value
    wsReport.Range("H" & i).Value = CalculateGrade(lMarks)
    'Calculate Total Units
    lTotalUnits = lMarks + lTotalUnits
   
Next i

' Calculate Average Marks and Grade
lAvgUnits = (lTotalUnits / (lrow - 1))
sAvgGrade = CalculateGrade(lAvgUnits)

wsReport.Range("H20").Value = lAvgUnits
wsReport.Range("H21").Value = sAvgGrade

End Sub

Calculate Grade

Option Explicit

Function CalculateGrade(flMarks As Long) As String

    Dim sGrade As String
    Select Case flMarks
        Case Is >= 900
            sGrade = "A"
        Case Is >= 800
            sGrade = "B"
        Case Is >= 700
            sGrade = "C"
        Case Is >= 600
            sGrade = "D"
        Case Else
            sGrade = "F"
    End Select
    CalculateGrade = sGrade

End Function

Save As PDF

Option Explicit

Sub CreateAndSendPDFCopy(sStudentID As String)

''Testing
'Dim sStudentID As String
'sStudentID = "SK10005"

'Save a PDF
Dim sFileName As String, sFullPath As String
sFileName = sStudentID
sFileName = sFileName & ".pdf"
sFullPath = sFilePath & sFileName

wsReport.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFullPath

'Send Email
Dim sEmailId As String
Dim rngFind As Range
Set rngFind = wsStudents.Range("A:A").Find( _
                                what:=sStudentID, LookIn:=xlValues)
If Not rngFind Is Nothing Then
    sEmailId = rngFind.Offset(0, 2).Value
End If

Call EmailPDF(sFullPath, sEmailId)

End Sub

Email PDF

Option Explicit

Sub EmailPDF(sFullPath As String, sEmailId As String)

' Connect to Outlook
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")

'Create Email Object
Dim oMail As Object
Set oMail = oApp.CreateItem(0)

With oMail
    .To = sEmailId
    .CC = ""
    .BCC = ""
    .Subject = "Report Card"
    .HTMLBody = "Hi There,<br>" & _
            "Please find your Report Card attached.<br>" & _
            "Regards,"
    .Attachments.Add sFullPath
    '.Send
    .Display
End With

End Sub

Related Posts