I have a lot of macro workbooks that consolidate multiple data ranges from individual tabs in the same workbook into one summary tab but today I discovered how to consolidate data ranges from different excel workbooks into one summary workbook.

My task today was to consolidate one of the worst NHS SLAM reports that we receive. This particular culprit has somewhere in the region of 20 tabs relating to a particular care type - such as outpatients, admitted patient care, A&E etc, we then get 5 copies of this for each PCT. Multiply this by 12 for each month of the year and you start to have quite an horrendous copy and paste task if you want to pull it all together manually.

I’ve been working on some VBA macro code to pull the data range from each tab of the monthly return and then stack them on top of each other.

I found snippets of code all over the web but I think the original code writer was Ron de Bruin who has some excellent VBA macro examples. Ron de Bruin offers a number of ways to work with the different workbooks, such as working through all workbooks in a set folder or looping through a user defined selection of workbooks. I have chosen to go with the latter option so that I can easily flick through each months SLAM folders.

As this macro is to work across multiple workbooks it needs to be saved in a normal module.

#If VBA7 Then Declare PtrSafe Function SetCurrentDirectoryA Lib \_ "kernel32" (ByVal lpPathName As String) As Long #Else Declare Function SetCurrentDirectoryA Lib \_ "kernel32" (ByVal lpPathName As String) As Long #End If


Sub ChDirNet(szPath As String) SetCurrentDirectoryA szPath End Sub

Sub MergeSpecificWorkbooks() Dim MyPath As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant Dim FirstCell As String

' Set application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With

SaveDriveDir = CurDir ' Change this to the path\\folder location of the files. ChDirNet "C:\\Consolidation\\"

FName = Application.GetOpenFilename(filefilter:="Excel Files (\*.xl\*), \*.xl\*", \_ MultiSelect:=True)

'set common areas Dim Month As Long Month = InputBox("Please enter Month as number eg 1 or 12") Dim SLAMType As String SLAMType = InputBox("Please enter either FLEX or FREEZE")

If IsArray(FName) Then

'Add a new workbook with one sheet. Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) rnum = 1

' Loop through all files in the myFiles array. For FNum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(FNum)) On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next With mybook.Worksheets("APC") 'include header for first workbook If FNum = 1 Then FirstCell = "A1" Else FirstCell = "A2" End If Set sourceRange = .Range(FirstCell & ":" & RDB\_Last(3, .Cells))

End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If the source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0

If Not sourceRange Is Nothing Then

SourceRcount = sourceRange.Rows.Count

If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else

' Copy the file name in column A. With sourceRange BaseWks.Cells(rnum, "A"). \_ Resize(.Rows.Count).Value = FName(FNum) BaseWks.Cells(rnum, "b"). \_ Resize(.Rows.Count).Value = Month BaseWks.Cells(rnum, "c"). \_ Resize(.Rows.Count).Value = SLAMType End With

' Set the destination range. Set destrange = BaseWks.Range("d" & rnum)

' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. \_ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If

Next FNum BaseWks.Columns.AutoFit End If

ExitTheSub: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ChDirNet SaveDriveDir End Sub

In order to set a dynamic range I am also using a function that Ron de Bruin also coded, which is called RDB_Last and determines the last used cell or row.

Function RDB\_Last(choice As Integer, rng As Range) 'Ron de Bruin, 5 May 2008 ' 1 = last row ' 2 = last column ' 3 = last cell Dim lrw As Long Dim lcol As Integer

Select Case choice

Case 1: On Error Resume Next RDB\_Last = rng.Find(What:="\*", \_ after:=rng.Cells(1), \_ Lookat:=xlPart, \_ LookIn:=xlFormulas, \_ SearchOrder:=xlByRows, \_ SearchDirection:=xlPrevious, \_ MatchCase:=False).Row On Error GoTo 0

Case 2: On Error Resume Next RDB\_Last = rng.Find(What:="\*", \_ after:=rng.Cells(1), \_ Lookat:=xlPart, \_ LookIn:=xlFormulas, \_ SearchOrder:=xlByColumns, \_ SearchDirection:=xlPrevious, \_ MatchCase:=False).Column On Error GoTo 0

Case 3: On Error Resume Next lrw = rng.Find(What:="\*", \_ after:=rng.Cells(1), \_ Lookat:=xlPart, \_ LookIn:=xlFormulas, \_ SearchOrder:=xlByRows, \_ SearchDirection:=xlPrevious, \_ MatchCase:=False).Row On Error GoTo 0

On Error Resume Next lcol = rng.Find(What:="\*", \_ after:=rng.Cells(1), \_ Lookat:=xlPart, \_ LookIn:=xlFormulas, \_ SearchOrder:=xlByColumns, \_ SearchDirection:=xlPrevious, \_ MatchCase:=False).Column On Error GoTo 0

On Error Resume Next RDB\_Last = rng.Parent.Cells(lrw, lcol).Address(False, False) If Err.Number > 0 Then RDB\_Last = rng.Cells(1).Address(False, False) Err.Clear End If On Error GoTo 0

End Select End Function

This has worked quite nicely for me. I’ve amended the original code to enable me to set a column for the month and define the source as either Flex or Freeze data and as I’ve shown it above, it will rapidly group defined worksheets (or tabs) into one summary workbook eg. month 6 outpatient data from 5 PCT files consolidated into 1 summary workbook.

I would now like to amend the code so that it will automatically loop through an array of worksheet names as each month’s report is opened so that outpatients and A&E and APC etc are consolidated in one go. At the moment I have to change the worksheet name for each care group, so it is still quite a manual process.

Eg, change

On Error Resume Next With mybook.Worksheets("OP") Set sourceRange = .Range("A1:C1") End With

to

On Error Resume Next With mybook.Worksheets("APC") Set sourceRange = .Range("A1:C1") End With

I’ve included a few dummy SLAM files for Trust 1 and Trust 2 and a blank Consolidation workbook that includes the macro. If you download them and save them to a folder called Consolidation in the C drive to match the path in the script of C:\Consolidation\ you should be able to see the macro in action.