OPen Files Using VBA 1

[robcarr]

Dear All,

Is there away to open all Excel files within a folder(previous months, each day saved individually) and then copy all data from row 8 and below(varying lengths of data) to a new file all the data needs to be in one big list on one sheet, also if the max no. of rows is hit the rest of the data goes on to sheet2.

If anyone can help with this, I would be really grateful.

Rob.

 

[Loomah]

Hi rob
Due to people keeping interupting me with work (agfain) this is only a starter for you. It doesn't take into account running off the end of a sheet. This will mean counting rows copied against rows already used in the destination.

The code assumes that data copied is contiguous so the 'CurrentRegion' will work. If not it'll mean playing with different methods of range selection. The other assumption(s) is that there are no formulas and that you want your data to start at A1 of the destination book.

Like I say, this will get you started. I've tested it with 8 books of about 650 rows of data.

Option Explicit

Sub OpenAndCopy()
Dim oFso, oFold, f1, oFiles
Dim wbkMe, wbk2 As Workbook
' set up the files
Set oFso = CreateObject("Scripting.FileSystemObject&quot
Set oFold = oFso.GetFolder _
("N:\STA02715\All Tests\Excel\Rubbish_Data&quot
Set oFiles = oFold.Files
Set wbkMe = ThisWorkbook
For Each f1 In oFiles
' only interested in xl files
If f1.Name Like "*.xls" Then
Set wbk2 = Workbooks.Open(Filename:=f1)
wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion.Copy
With wbkMe.Worksheets("SHEET1&quot
.Activate
.Range("A1&quot.Select
If IsEmpty(.Range("A1&quot) And _
.Range("A1&quot.End(xlDown).Row = 65536 Then _
ActiveSheet.Paste
If Not IsEmpty(.Range("A1&quot) Then
.Range("A1&quot.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
End With
Application.CutCopyMode = False
wbk2.Close
Set wbk2 = Nothing
End If
Next

End Sub

;-) If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."

 

[Loomah]

Rob
Some amendments but it's easier to post all the code again. It should now move to "Sheet2" if "Sheet1" is full.

It's very messy code, and it will be worth working thru to optimise and trap potential errors.

Hope it's what you're looking for
Option Explicit

Sub OpenAndCopy()
Dim oFso, oFold, f1, oFiles
Dim wbkMe, wbk2 As Workbook
'ADDED
Dim lCpdRows As Long
Dim ws As String
' set up the files
Set oFso = CreateObject("Scripting.FileSystemObject&quot
Set oFold = oFso.GetFolder _
("N:\STA02715\All Tests\Excel\Rubbish_Data&quot ' folder with source data
Set oFiles = oFold.Files
Set wbkMe = ThisWorkbook
For Each f1 In oFiles
' only interested in xl files
If f1.Name Like "*.xls" Then
Set wbk2 = Workbooks.Open(Filename:=f1)
'ADDED
ws = "Sheet1"
With wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion
.Copy
lCpdRows = .Rows.Count
End With
If wbkMe.Worksheets("SHEET1&quot.Range("A65536&quot.End(xlUp).Row _
+ lCpdRows > 65536 Then ws = "Sheet2"
With wbkMe.Worksheets(ws) 'amended
.Activate
.Range("A1&quot.Select
' check for existing data
If IsEmpty(.Range("A1&quot) And _
.Range("A1&quot.End(xlDown).Row = 65536 Then _
ActiveSheet.Paste
' last row
If Not IsEmpty(.Range("A1&quot) Then
.Range("A1&quot.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
End With
Application.CutCopyMode = False
wbk2.Close
Set wbk2 = Nothing
End If
Next

End Sub

;-D If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."

 

[Loomah]

This sin't just because I like to see my name up here on the site, I got it wrong:~/

These lines need to be substituted as they are the wrong way around on the original.

' check for existing data
If Not IsEmpty(.Range("A61000&quot) Then
.Range("A1&quot.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If
If IsEmpty(.Range("A1&quot) And _
.Range("A1&quot.End(xlDown).Row = 65536 Then _
ActiveSheet.Paste


Ooooops If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."

 

[robcarr]

Thanks for that Loomah,

I am really grateful for doing that for me, I used to have to manually copy each file to the a master for the month, so yet again thanks. There is one little question, how can I get the file to not copy the titles for each block of data, currently is selects cell a8(the first cell with data I require), the currentregion then select the data in row 7(titles) and all data below, how can i get it to select all the data below cell A8 only, i thought I enter the CTRL-SHIFT right and then down option this would then only select the data to the right and below cell A8, but I couldn't get it to work, do you have any idea's.

Thanks for all your help yet again.

 

[xlbo]

try this:
range("A8:A" range("A65536&quot.end(xlup).row).copy
etc etc
Obviously, will only work if the data is always the same width
HTH
Geoff

 

[Loomah]

Rob
Again, this relies on CurrentRegion working in the first place then using Offset and resize to miss the header row.

Sub Resys()
With ActiveSheet.Range("A8&quot.CurrentRegion
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Select
End With
End Sub

;-) If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."

 

[Loomah]

Rob
In a quiet moment before I go home I tried what you were trying to do, out of interest (no life!) using the recorder, and it seems to work fine.....

[your starting point goes here].Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

;-)
If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."

 

[robcarr]

Loomah,

When I paste run the peice of coding :-

Sub Resys()
With ActiveSheet.Range("A8&quot.CurrentRegion
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Select
End With
End Sub
It selects all of the data Cell A8, but when it goes to copy it still selects the current region and looks to me as though it disregards the activecell when doing the copy.
I would like to try and do the coding using this way :-

your starting point goes here].Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

when I added this into the coding in this part.
ws = "Sheet1"
With wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion
.Copy
lCpdRows = .Rows.Count

the 1cpdrows =. rows.count
caused an error, I am not really sure what is going on here.
any help greatly appreciated.

 

[Loomah]

Rob
I'm not 100% sure what your problem is other than I haven't expalained myself clearly enough.

To use the resize method substitute
With wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion
.Copy
with
With wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
.Copy

To use the method you say you want to substitute
With wbk2.Worksheets("sheet1&quot.Range("A8&quot.CurrentRegion
.Copy
with
wbk2.Worksheets("sheet1&quot.Range("A8&quot.Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
and add
lCpdRows = Selection.Rows.Count

The second option is not as efficient but if it works for you then who's to argue!?

XLBO's method is another alternative if the restrictions he mentions aren't going to affect you. Again substitute the same line as above with the new code.

Finally, what is the error you get for 'lCpdRows'??
;-) If a man says something and there are no women there to hear him, is he still wrong?
"...Three Lions On A Shirt..."