A lab billing macro example

Here is another useful macro for copying data from multiple workbooks into one workbook. At the end of the month billing needs a report with all the months charges listed. We have been creating a workbook daily with the day’s charges listed. Now we have to collate all those workbooks into one workbook. Again it’s a tedious process in need of automation.

To work this macro needs a sheet to copy to. I take the easy road and create a workbook name MasterWorkbook. I run the macro and it copies all the month’s workbooks to the MasterWorkbook. Then I save MasterWorkbook with a new name denoting the month. this way the original remains blank for next month. To work all the workbooks/sheets need to be in one folder. It copies all data from all workbooks in that folder to one.

How to get a list of workbooks in a folder:

We have gathered all the month’s files in one folder. The first step is to get a list of all the excel workbooks in this folder.

Sub AggregateReports()
    'Get a folder full of reports and put them all into one sheet.
    'Get the folder from user.
    On Error GoTo ErrorHandler

    Dim fldr As FileDialog
    Dim strFolder As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select the Folder where all the daily reports reside"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> 0 Then
            strFolder = .SelectedItems(1)
        Else 'Cancelled
            strFolder = ""
        End If
    End With

    Debug.Print "Folder was: " & strFolder
    Application.ScreenUpdating = False

We have the folder name now we need to get a list of only the excel files within that folder. We do this with the old Dir command. If you recall in MS-Dos dir used to list all the files in a folder. It’s almost the same in vba, except Dir returns the name of the first file and must be called again to get the next.

    'Get all filenames within folder.
    Dim Files() As String
    ReDim Files(-1 To -1)
    ThisWB = ThisWorkbook.Name
    Filename = Dir(strFolder & "\*.xls", vbNormal)
    Do Until Filename = ""
        If Filename <> ThisWB Then
            If UBound(Files) = -1 Then
                ReDim Files(0 To 0)
                If Filename = "" Then
                Else
                    Files(0) = Filename
                End If
            Else
                ReDim Preserve Files(0 To UBound(Files) + 1)
                Files(UBound(Files)) = Filename
            End If

            Debug.Print "Added: " & Filename
        Else
            Debug.Print "Excluded this workbook: " & Filename
        End If
        Filename = Dir()
    Loop

We now have a list of files but sadly they are in no particular order. A simple sort of the files will ensure that when we loop through them (as long as you have named them all in the same format with a date) the days will get copied in order.

How to do a quick sort in excel vba:

Private Sub QuickSort(strArray() As String, intBottom As Integer, intTop As Integer)
    Dim strPivot As String, strTemp As String
    Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    While (intBottomTemp <= intTopTemp)

        'comparison of the values is a descending sort
        While (strArray(intBottomTemp) < strPivot And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Wend

        While (strPivot < strArray(intTopTemp) And intTopTemp > intBottom)
            intTopTemp = intTopTemp - 1
        Wend

        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If

        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If

    Wend

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSort strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSort strArray, intBottomTemp, intTop

End Sub

This is a great and simple quicksort function but how do we use it? It’s simple:

    'NOTE: We are still in sub AggregateReports here:
    'Files come in all willy nilly, sort them by date
    QuickSort Files, LBound(Files), UBound(Files)

    Dim intX As Integer
    For intX = LBound(Files) To UBound(Files)
        Debug.Print "After Sort: " & Files(intX)
    Next intX

Now we have our list of files we just need to loop through it and copy them to the MasterWorkbook:

    'NOTE: we are still in sub AggregateReports here:
    Dim wkb As Workbook
    Dim intFinalRow As Integer
    Dim intRow As Integer
    Dim blnHeaderDone As Boolean

    For intX = LBound(Files) To UBound(Files)
            Set wkb = Workbooks.Open(Filename:=strFolder & "\" & Files(intX))
            wkb.Activate
            With wkb.Sheets(1)
                Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
                .Activate
                intFinalRow = Range("A65536").End(xlUp).Row  '
                For intRow = 2 To intFinalRow
                    If blnHeaderDone = False Then
                        'We only want to copy the header row once so we do it here and set variable to True
                        Rows(intRow - 1).EntireRow.Copy (Sheets(1).Range("a65536").End(xlUp).Offset(0, 0))
                        blnHeaderDone = True
                    End If
                    Rows(intRow).EntireRow.Copy (Sheets(1).Range("a65536").End(xlUp).Offset(1, 0))
                    If intRow = 2 Then 'This add's a 'Begin' comment to the first cell of that day.
                        Sheets(1).Range("a65536").End(xlUp).Offset(0, 7).AddComment ("Day " & CStr(intX) & " Begin: " & Files(intX))
                    End If
                    If intRow = intFinalRow Then 'Add end
                        Sheets(1).Range("a65536").End(xlUp).Offset(0, 7).AddComment ("Day " & CStr(intX) & " End: " & Files(intX))
                    End If

                Next intRow

            End With
            wkb.Close False

    Next intX 'next file.
    Application.ScreenUpdating = True

    Exit Sub
ErrorHandler:
    Debug.Print Err.Number & " " & Err.Description & " " & Erl
    MsgBox Err.Number & " " & Err.Description & " " & Erl
End Sub

And voila! Another 30 minutes saved!

You can download the workbook with macro here: MasterWorkbook

[ad name=”Synap blog wide”]