Visit my Youtube Channel
Build a Worksheet to Control the Flow of a Macro
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.
In this video, we configure the Excel front-end i.e. a worksheet, from where we can control various elements of a reporting macro. The idea is to build this macro for a third-person user and give them the ability to:
- input various details such as folder path to pick up file from
- run the macro in individual steps or run in one flow
- and, trouble-shoot errors (themselves) that occur due to incorrectly entered details in the input areas.
There will be a huge emphasis on error handling. You will find a lot of tips and tricks all along within this video, such as:
- how to use Radio Option buttons
- how to use Enums
- how to send an email based on details entered on a worksheet
- how to split the email subject onto various lines
- how check if a file or folder exists on our computer drive
- how to validate a file name and check for extension
- how to validate email addresses
Full Code
Parent Sub
Option Explicit
Sub FullMacroRun()
On Error GoTo AdminOverride
wsErrors.Cells.Clear
DeactivateUpdatesAndAlerts
Dim sAction As String
sAction = wsConsole.Range("E2").Value
' No Action is Selected
If sAction = "" Then
RecordError ("E-9001")
GoTo TerminateSub
End If
' Full Run or Import Only is Selected
Dim sInputFolderPath As String, sInputFileName As String, sInputFullFilePath As String
If sAction = Action.FullRun Or sAction = Action.ImportFileOnly Then
sInputFolderPath = wsConsole.Range("I3").Value
sInputFileName = wsConsole.Range("I4").Value
sInputFullFilePath = GetValidFilePath(sInputFolderPath, sInputFileName, "Input")
If sInputFullFilePath = "" Then GoTo TerminateSub
If FileExists(sInputFullFilePath, "Input") = False Then GoTo TerminateSub
ImportData (sInputFullFilePath)
End If
' Full Run or Export Only or Email Only is Selected
Dim sOutputFolderPath As String, sOutputFileName As String, sOutputFullFilePath As String
If sAction = Action.FullRun Or sAction = Action.ExportFileOnly Or sAction = Action.SendEmailOnly Then
sOutputFolderPath = wsConsole.Range("I7").Value
sOutputFileName = wsConsole.Range("I8").Value
sOutputFullFilePath = GetValidFilePath(sOutputFolderPath, sOutputFileName, "Output")
If sOutputFullFilePath = "" Then GoTo TerminateSub
End If
' Full Run or Export Only is Selected
If sAction = Action.FullRun Or sAction = Action.ExportFileOnly Then
If FileExists(sOutputFullFilePath, "Output") = True Then GoTo TerminateSub
TransformData (sOutputFullFilePath)
End If
' Full Run or Email Only is Selected
Dim sPreview As String, sEmailSubject As String, sEmailBody As String
Dim sEmailSendTo As Variant
Dim lrow As Long
If sAction = Action.FullRun Or sAction = Action.SendEmailOnly Then
sPreview = wsConsole.Range("E8").Value
lrow = wsConsole.Range("K" & wsConsole.Rows.count).End(xlUp).Row
If lrow = 2 Then
RecordError ("E-1007")
GoTo TerminateSub
End If
sEmailSendTo = wsConsole.Range("K3:K" & lrow).Value
sEmailSubject = wsConsole.Range("I12").Value
sEmailBody = wsConsole.Range("I13").Value
If FileExists(sOutputFullFilePath, "Email") = False Then GoTo TerminateSub
If ValidateEmailParameters(sPreview, sEmailSubject, sEmailSendTo) = False Then GoTo TerminateSub
Call SendEmail(sPreview, sEmailSubject, sEmailSendTo, sEmailBody, sOutputFullFilePath)
End If
TerminateSub:
On Error GoTo 0
CheckForErrors
ActivateUpdatesAndAlerts
Exit Sub
AdminOverride:
On Error GoTo 0
RecordError
CheckForErrors
ActivateUpdatesAndAlerts
End Sub
Declare Enums
Option Explicit
Public Enum Action
FullRun = 1
ImportFileOnly = 2
ExportFileOnly = 3
SendEmailOnly = 4
End Enum
Public Enum PreviewEmail
Yes = 1
No = 2
End Enum
Supporting Logic
Option Explicit
Sub DeactivateUpdatesAndAlerts()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Sub
Sub ActivateUpdatesAndAlerts()
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function FindLookupValue(sheet As Worksheet, col As Long, searchValue As String, off As Long) As Variant
Dim findRng As Range
Set findRng = sheet.Columns(col).Find( _
what:=searchValue, lookAt:=xlWhole, SearchDirection:=xlNext)
If Not findRng Is Nothing Then
FindLookupValue = findRng.Offset(, off).Value
Else
FindLookupValue = ""
End If
End Function
Function GetEmailString(sfEmailSendTo As Variant) As String
Dim i As Long
Dim sEmailId As String
Dim fullEmailSendToString As String
For i = LBound(sfEmailSendTo, 1) To UBound(sfEmailSendTo, 1)
sEmailId = sfEmailSendTo(i, 1)
fullEmailSendToString = fullEmailSendToString & sEmailId & ";"
Next i
GetEmailString = fullEmailSendToString
End Function
Function GetValidFilePath(sfFolderPath As String, sfFileName As String, sfFlow As String) As String
If Right(sfFolderPath, 1) <> "\" Then
sfFolderPath = sfFolderPath & "\"
End If
If FolderExists(sfFolderPath, sfFlow) = False Then GoTo TerminateFunction
If FileNameIsCorrect(sfFileName, sfFlow) = False Then GoTo TerminateFunction
Dim sFullFilePath As String
sFullFilePath = sfFolderPath & sfFileName
GetValidFilePath = sFullFilePath
Exit Function
TerminateFunction:
GetValidFilePath = ""
End Function
Function FolderExists(sfFolderPath As String, sfFlow As String) As Boolean
If Dir(sfFolderPath, vbDirectory) = "" Then
Call RecordError("E-1001", sfFlow)
FolderExists = False
Else
FolderExists = True
End If
End Function
Function FileNameIsCorrect(sfFileName As String, sfFlow As String) As Boolean
If Len(sfFileName) <= 5 Then
Call RecordError("E-1002", sfFlow)
GoTo TerminateFunction
End If
If Len(sfFileName) > 5 Then
If Right(sfFileName, 5) <> ".xlsx" Then
Call RecordError("E-1002", sfFlow)
GoTo TerminateFunction
End If
End If
FileNameIsCorrect = True
Exit Function
TerminateFunction:
FileNameIsCorrect = False
End Function
Function FileExists(sfFullFileName As String, sfFlow As String) As Boolean
If Dir(sfFullFileName) <> "" Then
If sfFlow = "Output" Then
Call RecordError("E-1005", sfFlow)
End If
FileExists = True
Else
If sfFlow <> "Output" Then
Call RecordError("E-1004", sfFlow)
End If
FileExists = False
End If
End Function
Function ValidateEmailParameters(sfPreview As String, sfEmailSubject As String _
, sfEmailSendTo As Variant) As Boolean
If sfPreview = "" Then
RecordError ("E-9002")
GoTo TerminateFunction
End If
If sfEmailSubject = "" Then
RecordError ("E-1006")
GoTo TerminateFunction
End If
Dim i As Long
Dim sEmailId As String
For i = LBound(sfEmailSendTo, 1) To UBound(sfEmailSendTo, 1)
sEmailId = sfEmailSendTo(i, 1)
If IsValidEmailId(sEmailId) = False Then GoTo TerminateFunction
Next i
ValidateEmailParameters = True
Exit Function
TerminateFunction:
ValidateEmailParameters = False
End Function
Function IsValidEmailId(sfEmailId As String) As Boolean
Dim sEmailIdentifier As String
sEmailIdentifier = "@"
Dim count As Long
Dim found As Long
count = 0
found = InStr(1, sfEmailId, sEmailIdentifier)
Do While found > 0
count = count + 1
found = InStr(found + 1, sfEmailId, sEmailIdentifier)
Loop
If count = 0 Or count > 1 Then
RecordError ("E-1008")
IsValidEmailId = False
Else
IsValidEmailId = True
End If
End Function
Import Data
Option Explicit
Sub ImportData(sfInputFullFilePath As String)
Dim wb As Workbook
Set wb = Workbooks.Open(sfInputFullFilePath)
Dim rng As Range
Set rng = wb.Sheets(1).Range("A1").CurrentRegion
wsData.Cells.Clear
rng.Copy wsData.Range("A1")
wb.Close savechanges:=False
End Sub
Transform Data
Option Explicit
Sub TransformData(sfOutputFullFilePath As String)
wsData.Columns("F:I").Clear
Dim lrow As Long
lrow = wsData.Range("A1").CurrentRegion.Rows.count
Dim i As Long
For i = 2 To lrow
'Col F
wsData.Range("F1").Value = "Product Name"
wsData.Range("F" & i).Value = FindLookupValue(wsLookup, 1, wsData.Range("B" & i).Value, 1)
'Col G
wsData.Range("G1").Value = "Store Name"
wsData.Range("G" & i).Value = FindLookupValue(wsLookup, 4, wsData.Range("C" & i).Value, 1)
'Col H
wsData.Range("H1").Value = "Total Sales"
wsData.Range("H" & i).Value = wsData.Range("D" & i).Value * wsData.Range("E" & i).Value
Next i
Dim wb As Workbook
Set wb = Workbooks.Add()
wsData.Range("A1").CurrentRegion.Copy wb.Sheets(1).Range("A1")
wb.Sheets(1).Columns("A:H").AutoFit
wb.SaveAs sfOutputFullFilePath
wb.Close savechanges:=False
End Sub
Email File
Sub SendEmail(sfPreview As String, sfEmailSubject As String, _
sfEmailSendTo As Variant, sfEmailBody As String, sfFullAttachmentName As String)
Dim fullEmailString As String
fullEmailString = GetEmailString(sfEmailSendTo)
sfEmailBody = Replace(sfEmailBody, vbLf, "<br>")
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
Dim oMail As Object
Set oMail = oApp.CreateItem(0)
With oMail
.to = fullEmailString
.CC = ""
.BCC = ""
.Subject = sfEmailSubject
.HTMLBody = sfEmailBody
.Attachments.Add sfFullAttachmentName
Select Case sfPreview
Case PreviewEmail.Yes
.Display
Case PreviewEmail.No
.Send
Case Else
End Select
End With
End Sub
Error Handling
Option Explicit
Sub RecordError(Optional sfErrorCode As String, Optional sfSuffix As String)
Dim sErrorDesc As String
If sfErrorCode <> "" Then
sErrorDesc = FindLookupValue(wsAdmin, 1, sfErrorCode, 1)
End If
wsErrors.Range("A1").Value = "Error"
If sfSuffix <> "" And sfErrorCode <> "" And sErrorDesc <> "" Then
sErrorDesc = sfSuffix & " " & sErrorDesc
End If
If sErrorDesc = "" Then
sErrorDesc = "Please check with Macro Admin"
End If
wsErrors.Range("A2").Value = sErrorDesc
wsErrors.Columns.AutoFit
End Sub
Sub CheckForErrors()
If wsErrors.Range("A1").Value <> "" Then
wsErrors.Activate
MsgBox "Atleast one error found."
End If
End Sub