Recently a client asked me if I could create an Excel VBA procedure which picked up data from a file but the data came from multiple sheets and multiple cells in non sequential locations. Firstly, I thought the best method to do this would be to have a summary sheet which is hidden and simply pick this sheet up and consolidate it in the parent workbook. However the problem was the files had already gone out and over 200 Excel files needed to be consolidated into a single workbook.
So an Excel VBA procedure needed to be written which could extract data from multiple sheets in multiple different cell locations. Fortunately, a template had been established where every single one of the over 200 files was identical. This is important, as you can extract cell locations with certainty.
Attacking the problem I thought the best was to interrogate the data was through 2 arrays. One to store the sheet and cell location data and a second to store the values from each of those locations. There was almost 400 cells to extract from each workbook (YIKES). So this influenced my decision to work with arrays rather than to copy and paste the data from one sheet to another.
The file is set up as such. On Sheet1 in Column A:
Sheet Name - EG - Data
In Column B:
Cell Location - EG - E5
All of the sheet names and cell locations are named down the sheet. In Column C there is a cell Description. What each cell your extracting is.
C2 - Legal Expenses.
A little bit about the code.
- The file Path is specific to my machine and will need to change.
- Option Base 1 is used to get the deposit variable (Var) to start at 1.
- The contents of the destination sheet is cleared before the procedure is run.
- The file name is held in the 4th variable, this is placed in Column 1 of the consolidation sheet (sheet3) in my example.e
- The use of ReDim in the procedure is to clear the variable Var so when a new file is opened the variable is ready to accept new data.
The following is the VBA procedure. It will need to be customised slightly but should provide a solid start to any project of this nature.
Option Explicit
Option Base 1
Sub Consol() 'Excel VBA to open and import data from the Excel files in a directory
Const sPath = "C:\SmallMan\Test\" 'Change to suit
Dim sFil As String
Dim owb As Workbook
Dim ws As Worksheet
Dim ar As Variant
Dim var
Dim i As Integer
Dim lr As Long
Dim rws As Integer
rws = 380 'Change to suit (if they don't match your code fails!!!)
Application.ScreenUpdating = False 'Stop screen flicker.
ar = Sheet1.Range("a2", Sheet1.Range("B1000").End(xlUp))
ReDim var(rws)
Set ws = Sheet3 'Change to Sheet2 (Database) when Satisfied and alter this text.
ws.[B3:C200000].ClearContents 'Clear 200K rows of contents to start process
sFil = Dir(sPath & "*.xl*") 'Flexible enough to handle all XL file types
Do While sFil <> "" 'Loop which opens the file
Set owb = Workbooks.Open(sPath & sFil, 0) 'Open file but supress message = 0
Sheet1.Range("C2:C" & rws + 1).Copy ws.Range("C65536").End(xlUp)(2) 'Copy Header.
For i = 1 To UBound(ar)
var(i) = Sheets(ar(i, 1)).Range(ar(i, 2)).Value 'Move the values to variable called VAR.
Next i
sFil = Dir
owb.Close False 'Close no save
lr = ws.Range("C65536").End(xlUp).Row 'Trap the last row in the file Col C in Test Sheet.
ws.Range(Cells(lr + 1 - rws, 2), ws.Cells(lr, 2)) = Application.Transpose(var) 'Transpose
ws.Range(Cells(lr + 1 - rws, 1), ws.Cells(lr, 1)) = var(4) 'CTDS don't change location.
ReDim var(rws) 'Reset Var for next file
Loop
Application.ScreenUpdating = True 'Turn the updating back on.
End Sub
Just a word to the wise. The above procedure is not designed to extract data from sequential locations. The type of code in the following locations will be more efficient and there will be less code to take in, manipulate and understand.
Hope this post helps.
