≡ Menu

Macro to Consolidate Data Ranges from Multiple Excel Spreadsheets

Excel Macro

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

multiple tabs Macro to Consolidate Data Ranges from Multiple Excel Spreadsheets

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.

VB Module 300x202 Macro to Consolidate Data Ranges from Multiple Excel SpreadsheetsI 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
#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 "N:\NAS Islington\ISL - Strat & Comm\Gen & Spec Acute Comm & Contg\Acute Comm\Acute Providers\Nth Cet Ldn Sctr\Barnet & Chase Farm\2011-12\Activity data\Wolff Analysis\Macro"

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))
' Test if the row of the last cell is equal to or greater than the row of the first cell.
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then Set sourceRange = Nothing End If 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
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.

{ 1 comment… add one }

  • Julio Wells February 12, 2013, 5:25 pm

    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.

Leave a Comment