Collate information from different files via a macro

Nav

unread,

Apr 12, 2007, 10:08:05 AM4/12/07

to

Hello

I have 10 files (1 per person- S:\data\(initials)) they have the same format
(1st four columns) with data in them with the first row as a header. I wish
to create 1 file for all this data, is there an easy way to obtain the data
from all the files and create a new one under S:\data\combined without having
to open then all 1 by one and copy and insert the cells into the new combined
file (the data range also changes on a day to day basis).

Please can you provide suggestions, thank you in advance for your help.

Regards.

Norman Jones

unread,

Apr 12, 2007, 10:36:41 AM4/12/07

to

Hi Nav,

See Ron de Bruin's sample code at:

Copy a range from closed workbooks (ADO)
http://www.rondebruin.nl/ado.htm

---
Regards,
Norman

"Nav" <N...@discussions.microsoft.com> wrote in message
news:009C36FE-2233-440D...@microsoft.com...

Incidental

unread,

Apr 12, 2007, 12:09:44 PM4/12/07

to

Hi Nav

you could try something like the following which will open each excel
file in a given directory and copy all the data in the first four
columns (except the header) and paste it in the workbook running the
code. it will then save a copy of the workbook in the desired
folder. Then close the workbook you ran the code from without saving.

add a module to a workbook then paste the following code into that
module, you can then trigger the macro by a keyboard shortcut or a
button ect.

Option Explicit
Dim MyFile As String
Dim MyWkBk As String
Dim Directory As String
Dim LstCell As String

Sub GetMyData()
MyWkBk = ActiveWorkbook.Name
Directory = "C:\Test\" 'change this to the directory for your files
MyFile = Dir(Directory & "\*.xls")
Do Until MyFile = ""
Workbooks.Open (Directory & MyFile)
LstCell = [A1].End(xlDown).Offset(0, 3).Address
Range("A2", LstCell).Copy
Workbooks(MyWkBk).Activate
If [A2].Value = "" Then
[A2].Activate
Else
[A2].End(xlDown).Offset(1, 0).Activate
End If
ActiveCell.PasteSpecial xlPasteValues
Application.CutCopyMode = False
Workbooks(MyFile).Close (False)
MyFile = Dir
Loop

ActiveWorkbook.SaveCopyAs "S:\data\combined" 'this directory must
exist or it will give an error
End Sub

hope this gives you an idea of what to do

S

Norman Jones

unread,

Apr 12, 2007, 12:21:23 PM4/12/07

to

Hi Incidental,

I think that Nav was seeking not to open the source files.

---
Regards,
Norman

"Incidental" <incid...@hotmail.co.uk> wrote in message
news:1176394184.7...@n76g2000hsh.googlegroups.com...

urkec

unread,

Apr 12, 2007, 1:26:00 PM4/12/07

to

Hi,

I think you can use something like this

Sub getData()

'On Error Resume Next

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1

'put all the file names without extension
'into an array
initials = Array("XX", "XY", "XZ", "XA")

'overwrite existing combined.xls
Application.DisplayAlerts = False

'add header rows to combined.xls
Set combined = Workbooks.Add
With combined.Sheets(1)
.Cells(1, 1) = "first"
.Cells(1, 2) = "second"
.Cells(1, 3) = "third"
.Cells(1, 4) = "fourth"
End With

'save and close combined.xls
combined.SaveAs "S:\data\combined.xls"
combined.Close

'connect to combined.xls using ADO
Set CnnOut = CreateObject("ADODB.Connection")
Set rsOut = CreateObject("ADODB.Recordset")

CnnOut.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=S:\data\combined.xls;" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"

rsOut.Open "Select * FROM [Sheet1$]", _
CnnOut, adOpenStatic, adLockOptimistic, adCmdText

'loop through initials array
'to construct the appropriate file name
'XX.xls, XY.xls ...
For Each initial In initials

Set Cnn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")

Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=S:\data\" & initial & ".xls;" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"

'get the data from each .xls file
Rs.Open "Select * FROM [Sheet1$]", _
Cnn, adOpenStatic, adLockOptimistic, adCmdText

'write the data to combined.xls
Do Until Rs.EOF

rsOut.AddNew
rsOut!first = Rs!first
rsOut!Second = Rs!Second
rsOut!third = Rs!third
rsOut!fourth = Rs!fourth
rsOut.Update
Rs.MoveNext

Loop

'clean up for the next .xls file
Set Rs = Nothing
Set Cnn = Nothing

End Sub

--
urkec

Incidental

unread,

Apr 13, 2007, 4:01:15 AM4/13/07

to

On 12 Apr, 17:21, "Norman Jones" <normanjo...@whereforartthou.com>
wrote:

> Hi Incidental,
>
> I think that Nav was seeking not to open the source files.
>
> ---
> Regards,
> Norman
>

Hi Norman

On reading it again your right norman, in my defence it was a very
sunny day yesterday and i did spend most of the day staring out the
window in a day dream waiting for 5pm to role around so i might not
have been paying attention to well lol

Steve

Nav

unread,

Apr 18, 2007, 6:58:02 AM4/18/07

to

Thank you for this, but I keep getting a runtime 3265 error - "Item cannot be
found in the collection corresponding to the requested name or ordinal".

It keeps stopping for debug at the code:

rsOut!first = Rs!first

Thanks anyway.

Nav

unread,

Apr 18, 2007, 7:02:01 AM4/18/07

to

Hello - thank you for this.

But are you aware if there is anyway to copy the data from a range named
DATA (which is a dynamic range), as the code for below requires you to know
the exact range, I have tried substituting DATA into the code where the range
is stated but this does not work.

Thank you again for all your help.