VBA Project – Send Reports and Reconcile Responses

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 post, we are going to build an end to end project designed to address a real-life business problem. How to send information out to team members and how to collect back responses?

Imagine we are in the Accounting Department and there are a lot of overdue invoices. And our biggest question is? Are we are going to get the money back or do we need to write these invoices off. So, to find out,

  • we will split our master dataset of overdue invoices into individual reports for each account,
  • email each of our offsite Sales Team member the report related to their accounts,
  • they will need to confirm the statuses of the invoices within that spreadsheet,
  • send the file back to us,
  • and we will need to compile and reconcile all their responses back to our main data set.

This is a big work-flow. And we are going to automate the whole thing. Trying to achieve this flow manually is a nightmare. And MS Forms and MS Teams are just not dynamic enough to handle the level of customization that we require. So, its VBA to the rescue as usual.

Outbound Macro

The objective of the Outbound macro is to Send an Excel Report File with Comments’ Columns to each Sales Person.

So, in Step 1, we will create a unique list of sales persons from the main dataset.

In Step 2, we will gather a list of fixed comments for our drop down list.

Next, we will create a loop in VBA that will iterate over each Sales Person that we have identified in our Unique List from Step 1.

Step 3, we will separate out the data for each Sales Person.

Step 4, we will create a separate file based on the data that we have just isolated.

Step 5, we will email this file to the respective Sales Person.

Parent Macro

Sub SendFilesToSalesPersons()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    wsWork.Cells.Clear
    wsWork.Range("A1").Value = "Sales Person"
    wsData.Range("A1").CurrentRegion.Rows(1).Copy wsWork.Range("C1")
    wsWork.Range("K1").Value = "Sales Person"
    
    Call FindUniqueSalesPersons
    Dim sComments As String
    sComments = CreateListString
    
    Dim lrow As Long
    lrow = wsWork.Range("A1").CurrentRegion.Rows.Count
    Dim i As Long
    Dim sSalesPerson As String, sFileName As String, sEmailId As String
    For i = 2 To lrow
        sSalesPerson = wsWork.Range("A" & i).Value
        sFileName = sOutputFolder & sSalesPerson
        Call IsolateIndividualData(sSalesPerson)
        Call CreateIndividualFile(sFileName, sComments)
        sEmailId = GetEmailId(sSalesPerson)
        Call SendEmail(sEmailId, sFileName)
    Next i
    

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

Create a Unique List of Sales Person

Sub FindUniqueSalesPersons()

    Dim rngList As Range
    Set rngList = wsData.Range("A1").CurrentRegion
    Dim rngCopyTo As Range
    Set rngCopyTo = wsWork.Range("A1")
    
    rngList.AdvancedFilter xlFilterCopy, , rngCopyTo, Unique:=True


End Sub

Gather a list of fixed comments

Function CreateListString() As String

    Dim lrow As Long
    lrow = wsList.Range("A1").CurrentRegion.Rows.Count
    Dim strList As String
    Dim i As Long
    For i = 1 To lrow
        strList = strList & "," & wsList.Range("A" & i).Value
    Next i
    strList = Right(strList, Len(strList) - 1)
    CreateListString = strList
End Function

Separate out the data

Sub IsolateIndividualData(sSalesPerson As String)

    wsWork.Range("C2:K" & wsWork.Rows.Count).Clear
    wsWork.Range("K2").Value = sSalesPerson
    Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
    Set rngList = wsData.Range("A1").CurrentRegion
    Set rngCriteria = wsWork.Range("K1").CurrentRegion
    Set rngCopyTo = wsWork.Range("C1").CurrentRegion.Rows(1)
    
    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo

End Sub

Create a separate file

Sub CreateIndividualFile(sFileName As String, sComments As String)

    Dim wb As Workbook
    Set wb = Workbooks.Add
    Dim ws As Worksheet
    Set ws = wb.Sheets("Sheet1")
    wsWork.Range("C1").CurrentRegion.Copy ws.Range("A1")
    ws.Columns.AutoFit
    Dim lrow As Long
    lrow = ws.Range("A1").CurrentRegion.Rows.Count
    ws.Range("G1").Value = "Action"
    ws.Range("H1").Value = "Remarks"
    ws.Range("G2:H" & lrow).Locked = False
    ws.Range("G2:G" & lrow).Validation.Add xlValidateList, _
                            AlertStyle:=xlValidAlertStop, _
                            Formula1:=sComments
    ws.Range("A1").AutoFilter
    ws.Protect Password:="pwdSheet", AllowFiltering:=True
    wb.SaveAs sFileName, FileFormat:=xlWorkbookDefault
    wb.Close savechanges:=False

End Sub

Email the file

Get Email ID

Function GetEmailId(sSalesPerson As String) As String

    Dim rngSearch As Range
    Set rngSearch = wsEmail.Columns("A")
    
    Dim rngEmail As Range
    Set rngEmail = rngSearch.Find( _
                        What:=sSalesPerson).Offset(0, 1)
    If Not rngEmail Is Nothing Then
        GetEmailId = rngEmail.Value
        Else
        GetEmailId = ""
    End If

End Function

Send Email

Sub SendEmail(sEmailId As String, sFileName As String)
    sFileName = sFileName & ".xlsx"
    ' Connect to Outlook
    Dim oApp As Object
    Set oApp = CreateObject("Outlook.Application")
    Dim oMail As Object
    Set oMail = oApp.CreateItem(0)
    
    With oMail
        .to = sEmailId
        .CC = ""
        .BCC = ""
        .Subject = "Outstanding Invoices"
        .HTMLBody = "Hi There, <br>" & _
                                "Please review the attached invoices <br>" & _
                                "Regards,"
        .Attachments.Add sFileName
        '.Send
        .Display
    End With

End Sub

Inbound Macro

Our objective is to now, reconcile each returned Excel report file with the original dataset. As a manual step, we would have copied and saved the outlook emails onto our computer. We are now ready to start the Inbound Macro

Step 1, we will extract the attachments from each Sales Person.

Step 2, we will grab the data from each report and compile it all together into a single Excel spreadsheet.

Step 3, we will reconcile back each compiled response back with the original dataset.

Parent Sub

Sub CollateSentFiles()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    wsResponse.Cells.Clear
    
    Call ExtractAttachments
    Call CollectResponseData
    Call MergeData
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Extract Attachments

Sub ExtractAttachments()

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim fldOutlookIn As Object
    Set fldOutlookIn = fso.GetFolder(sInputFolder & "Email")
    
    Dim oApp As Object
    Set oApp = CreateObject("Outlook.Application")
    
    Dim oMail As Object, oAttach As Object, fileItem As Object
    Dim sAttachName As String
    
    For Each fileItem In fldOutlookIn.Files
        Set oMail = oApp.CreateItemFromTemplate(fileItem.Path)
        For Each oAttach In oMail.Attachments
            sAttachName = oAttach.fileName
            sAttachName = sInputFolder & "Files" & "\" & sAttachName
            oAttach.SaveAsFile sAttachName
        Next oAttach
        Set oMail = Nothing
    Next fileItem

End Sub

Compile data

Sub CollectResponseData()

    Dim fileName As Variant
    fileName = Dir(sInputFolder & "Files\*.xlsx")
    Dim lrow As Long
    Dim wb As Workbook
    Dim fileCount As Long
    fileCount = 0
    
    Do While fileName <> ""
        Set wb = Workbooks.Open(sInputFolder & "Files\" & fileName)
        wb.Sheets("Sheet1").Unprotect Password:="pwdSheet"
        wb.Sheets("Sheet1").AutoFilterMode = False
        If fileCount = 0 Then
            wb.Sheets("Sheet1").Range("A1").CurrentRegion.Copy wsResponse.Range("A1")
            fileCount = 1
            Else
            wb.Sheets("Sheet1").Range("A1").CurrentRegion.Offset(1, 0).Resize _
                (wb.Sheets("Sheet1").Range("A1").CurrentRegion.Rows.Count - 1).Copy _
                wsResponse.Range("A" & lrow)
        End If
        lrow = wsResponse.Range("A1").CurrentRegion.Rows.Count + 1
        wb.Sheets("Sheet1").Protect Password:="pwdSheet", AllowFiltering:=True
        wb.Close savechanges:=False
        Set wb = Nothing
        fileName = Dir()
    Loop
  
End Sub

Reconcile Data

Sub MergeData()

    Dim i As Long
    Dim lrow As Long
    lrow = wsData.Range("a1").CurrentRegion.Rows.Count
    Dim rngSearch As Range
    Set rngSearch = wsResponse.Columns("B")
    Dim rngResponse As Range
    Dim sInvoiceNumber As String
    wsData.Range("G1:H1").Value = wsResponse.Range("G1:H1").Value
    For i = 2 To lrow
        sInvoiceNumber = wsData.Range("B" & i).Value
        Set rngResponse = rngSearch.Find( _
                                            What:=sInvoiceNumber)
        If Not rngResponse Is Nothing Then
            wsData.Range("G" & i).Value = rngResponse.Offset(0, 5).Value
            wsData.Range("H" & i).Value = rngResponse.Offset(0, 6).Value
            Set rngResponse = Nothing
        End If
        
    Next i
    
End Sub

Related Posts