Consolidate Ranges into 1 Workbook

[John]

I am looking for some simple Code that will open up all files in a certain
Directory, then copy a range within a certain sheet to one Workbook, then
close all Workbooks except for the Consolidated one, thus consolidating all
information

Basic information is as follows

All Files that I wish to open will have the same layout and woksheet names,
although each of these files will have a different workbook name
The range area I am looking to copy is A13:I13
This range will reside in a worksheet called "E-Import"
The Directory path where all these files will reside is C:\MIS\Labour
Module\Labour Import
My Consoldated File will be "Daily Labour Report w/e 18-12-05" - however
this name changes each week, as I create a new file for each week
The worksheet within my Consolidated file where all the file info wil be
copied to will be called "Consol Info"


Thanks

 

[Mike Fogleman]

Ron DeBruin has some code examples that can do exactly this. I would
recommend the ADO method that does not need to open the workbooks.
http://www.rondebruin.nl/ado.htm#files

See example #3 for multiple workbooks.
Mike F

 

[John]

Thanks Mike

I used Ron's Example 3, I copied exactly as is except changing the source
directory to "C:\MIS\Labour Module\Labour Import" but it hits debug at below
saying "User-Defined type not defined". Not sure what this means

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
sourceRange As String, TargetRange As Range, HeaderRow As
Boolean)

Dim rsData As ADODB.Recordset

 

[Mike Fogleman]

Did you set a reference as was explained at the top of Ron's page?

You must set a reference to the Microsoft ActiveX Data Objects 2.5 library
inthe VBA editor to use the examples below.
And also copy the functions/subs at the bottom?

Mike F

 

[Ron de Bruin]

Hi John

You forgot to set the reference

You must set a reference to the Microsoft ActiveX Data Objects 2.5 library

Download first the example zip to test

 

[John]

Thanks Mike / Ron

Superb, don't know much about References but it works

One small change which you might assist with, instead of adding a new
worksheet within the "consol" file how would I copy the source files into
the worksheet "Consol"?

 

[Ron de Bruin]

You can use this
Set sh = Worksheets("consol")


instead off

Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

 

[John]

Thanks Ron

You can use this
Set sh = Worksheets("consol")


instead off

Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

 

[John]

Ron

Instead of appending below the last row of data in the destination sheet is
it possile for it to always start at A1 i.e. copy over any data that maybe
there? I could add a simple Cells.Select Selection.ClearContents at the
start of your code, but is there an even simpler change within you code?

Thanks

 

[Ron de Bruin]

hi John

Use it like this then

Set sh = Worksheets("consol")
sh.Cells.ClearContents

 

[John]

Thanks Ron, thats a good piece of code you have. Instead of selecting files,
is there a way to select all files that reside in "MyPath" without having to
directly select them through Application.GetOpenFilename?

 

[Ron de Bruin]

Hi John

Maybe a good idea to add a example to my site with this.
I try to add it this evening ( or tomorrow)

 

[John]

Thanks Ron for your interest.You have a good site

 

[Ron de Bruin]

Hi John

I add this macro to my ADO page
http://www.rondebruin.nl/ado.htm


Sub GetData_Example4()
Dim MyPath As String
Dim FilesInPath As String
Dim sh As Worksheet
Dim MyFiles() As String
Dim Fnum As Long
Dim rnum As Long
Dim destrange As Range

MyPath = "C:\Data" ' <<<< Change

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp
Application.ScreenUpdating = False

'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = MyPath & MyFiles(Fnum)

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
'Set the last argument to True if you want to copy the header row also
GetData MyPath & MyFiles(Fnum), "Sheet1", "A1:C5", destrange, False
Next
End If

CleanUp:
Application.ScreenUpdating = True
End Sub

 

[John]

Thanks Ron, your code works like a dream and saves me about 50 mins of work
each day

 

[Ron de Bruin]

saves me about 50 mins

That's great

Thanks for the feedback