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.

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" wrote in message
...
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.

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

Hi Incidental,

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


---
Regards,
Norman



"Incidental" wrote in message
oups.com...
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

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

Next

'clean up for combined.xls
Set rsOut = Nothing
Set CnnOut = Nothing

End Sub


--
urkec


"Nav" wrote:

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.

On 12 Apr, 17:21, "Norman Jones"
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

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.

"urkec" wrote:

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

Next

'clean up for combined.xls
Set rsOut = Nothing
Set CnnOut = Nothing

End Sub


--
urkec


"Nav" wrote:

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.

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.

"Norman Jones" wrote:

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" wrote in message
...
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.