≡ Menu

Macro to Consolidate Data Ranges from Multiple Excel Spreadsheets

Excel Macro

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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
#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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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

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

to

1
2
3
4
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.

Trust 1 May Flex SLAM
Trust 2 May Flex SLAM
SLAM Consolidation Macro

Doctor Moxie

Written by -

NHS Accountant with geeky tendencies - serial blogger on subjects varying from Excel, Raspberry Pi, productivity, allotment gardening and running. The NHSExcel blog is reserved for Excel topics.

Comments on this entry are closed.

  • http://fructitza.wordpress.com/2012/09/16/elogiu-mamei-vitrege-mario-vargas-llosa/ Julio Wells

    Resize UserForm and controls When you open a workbook with a userform that you create in Excel for Windows you will notice that you think your getting old because the userform will popup very small and you need a optical device. You can copy the code below in the Userform module of your workbook to change the size automatic when you open the userform on a Mac. Change the 1.5(50 % larger) in the code if you think it is big or to small.

  • http://whatapalaver.co.uk Dr Moxie

    I’ve just updated this tutorial with some example workbooks and a working macro example. When I came to use this again at work I had a problem getting it to function so I’ve revised the code and tested it again.