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

Related Posts