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”]