Copy range from multiple files in multiple folders to single sheet in master WB
 

I have 30 files, each in a different folder on a network drive. I need to be able to copy the top 100 rows from the first sheet of each file and paste them into a single sheet in a master file on a monthly basis. (If that is not possible, I guess I could copy them to separate sheets and link all of the sheets to a "master" sheet in my master workbook.)

There are other Excel files in these directories, but the files I need to copy this range from share the word "Source" in the workbook name.The sheet name of the first sheet in every file is "CASH".

The copy and paste from the first file would fill rows 1 - 100 on the master sheet. The data from the second file would paste on rows 101 - 200 in the master sheet, and so forth. After all the data has been copied and pasted the file would automatically save. Some directory examples:

S:\Accounting\Film\WOLB\WOLB Source File.xls

S:\Accounting\Film\WITX\WITX Source File.xls

S:\Accounting\Film\WBBB\WBBB Source File.xls

If you can help me I would REALLY appreciate it. I've been unable to find a solution to this anywhere.

Thanks!

Copy range from multiple files in multiple folders to singlesheet in master WB
 

On Tuesday, July 17, 2012 1:49:35 PM UTC-5, Royzer wrote:
I have 30 files, each in a different folder on a network drive. I need
to be able to copy the top 100 rows from the first sheet of each file
and paste them into a single sheet in a master file on a monthly basis.
(If that is not possible, I guess I could copy them to separate sheets
and link all of the sheets to a "master" sheet in my master workbook.)

There are other Excel files in these directories, but the files I need
to copy this range from share the word "Source" in the workbook name.The
sheet name of the first sheet in every file is "CASH".

The copy and paste from the first file would fill rows 1 - 100 on the
master sheet. The data from the second file would paste on rows 101 -
200 in the master sheet, and so forth. After all the data has been
copied and pasted the file would automatically save. Some directory
examples:

S:\Accounting\Film\WOLB\WOLB Source File.xls

S:\Accounting\Film\WITX\WITX Source File.xls

S:\Accounting\Film\WBBB\WBBB Source File.xls

If you can help me I would REALLY appreciate it. I've been unable to
find a solution to this anywhere.

Thanks!




--
Royzer

Without testing the idea is to have a looping macro
for each f in range("mylistoffilenames"
fileopen
sheets(1).rows("1:100").copy _ destinationfile.cells(rows.count,1).end(xlup)(2)
filecloce
next f

Copy range from multiple files in multiple folders to single sheet in master WB
 

Royzer brought next idea :
I have 30 files, each in a different folder on a network drive. I need
to be able to copy the top 100 rows from the first sheet of each file
and paste them into a single sheet in a master file on a monthly basis.
(If that is not possible, I guess I could copy them to separate sheets
and link all of the sheets to a "master" sheet in my master workbook.)

There are other Excel files in these directories, but the files I need
to copy this range from share the word "Source" in the workbook name.The
sheet name of the first sheet in every file is "CASH".

The copy and paste from the first file would fill rows 1 - 100 on the
master sheet. The data from the second file would paste on rows 101 -
200 in the master sheet, and so forth. After all the data has been
copied and pasted the file would automatically save. Some directory
examples:

S:\Accounting\Film\WOLB\WOLB Source File.xls

S:\Accounting\Film\WITX\WITX Source File.xls

S:\Accounting\Film\WBBB\WBBB Source File.xls

If you can help me I would REALLY appreciate it. I've been unable to
find a solution to this anywhere.

Try this and report any bugs.
===========================================
Public Sub CollectFromEverywhere()
Dim FS As New FileSystemObject
Dim FS_subFolders As Object
Dim FS_Folders As Object, SourceFile As Object
Dim FS_Files As Object, xlApp As New Excel.Application
Dim colFolders_1 As Collection, SourceRange As Range
Dim colFolders_2 As Collection, n As Long, m As Long
Dim i, j, k, h As Long, NumRow As Integer, NumCol As Integer
Dim TargetRange As Range, SourceFolder As String

' Definitions ---------------------------
SourceFolder = "D:\Accounting\"
NumRow = 100
NumCol = 8
Set TargetRange = [MasterSheet!A1]
' ---------------------------------------

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set colFolders_1 = New Collection
colFolders_1.Add SourceFolder
On Error GoTo FolderNotFound
Set FS_Folders = FS.GetFolder(SourceFolder)
On Error GoTo 0
Set FS_Files = FS_Folders.Files
For Each k In FS_Files
GoSub CheckFileName
Next

Start:
'------
Set colFolders_2 = colFolders_1
Set colFolders_1 = New Collection
For Each i In colFolders_2
Set FS_Folders = FS.GetFolder(i)
Set FS_subFolders = FS_Folders.SubFolders
For Each j In FS_subFolders
Set FS_Folders = FS.GetFolder(j.Path)
colFolders_1.Add j.Path
Set FS_Files = FS_Folders.Files
DoEvents
For Each k In FS_Files
GoSub CheckFileName
Next k
Next j
Next i
If colFolders_1.Count 0 Then
GoTo Start
End If

Exit_Sub:
ThisWorkbook.Save
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

CheckFileName:
If InStr(1, k.Name, "Source") And Right(k, 4) = ".xls" Then
h = h + 1
Set SourceFile = xlApp.Workbooks.Open(k)
Set SourceRange =
SourceFile.Worksheets("CASH").Range("A1:H100")
For n = 1 To NumRow
For m = 1 To NumCol
TargetRange(n + NumRow * (h - 1), m) = SourceRange(n,
m)
Next
Next
SourceFile.Close
End If
Return

FolderNotFound:
MsgBox "Err. " & Err.Number & " - " & _
Err.Description & vbCrLf & vbLf & _
"Folder: " & UCase(SourceFolder) & _
" -- Not Found."
Resume Exit_Sub

End Sub
============================================

Bruno

Thank you, Bruno. I will try this when I return to work Thursday.

Roy

Bruno, my apologies for taking so long to try your code. If you do not wish to pursue this after all this time has passed, I understand.

The code on the second line "Dim FS As New FileSystemObject"
is giving me a "user defined type not defined" error:

These two lines under "CheckFileName" are showing in red when I paste the code:

Set SourceRange =

and

TargetRange(n + NumRow * (h - 1), m) = SourceRange(n,
m)




[code]
Public Sub CollectFromEverywhere()
Dim FS As New FileSystemObject
Dim FS_subFolders As Object
Dim FS_Folders As Object, SourceFile As Object
Dim FS_Files As Object, xlApp As New Excel.Application
Dim colFolders_1 As Collection, SourceRange As Range
Dim colFolders_2 As Collection, n As Long, m As Long
Dim i, j, k, h As Long, NumRow As Integer, NumCol As Integer
Dim TargetRange As Range, SourceFolder As String

' Definitions ---------------------------
SourceFolder = "S:\Accounting\film"
NumRow = 100
NumCol = 8
Set TargetRange = [MasterSheet!A1]
' ---------------------------------------

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set colFolders_1 = New Collection
colFolders_1.Add SourceFolder
On Error GoTo FolderNotFound
Set FS_Folders = FS.GetFolder(SourceFolder)
On Error GoTo 0
Set FS_Files = FS_Folders.Files
For Each k In FS_Files
GoSub CheckFileName
Next

Start:
'------
Set colFolders_2 = colFolders_1
Set colFolders_1 = New Collection
For Each i In colFolders_2
Set FS_Folders = FS.GetFolder(i)
Set FS_subFolders = FS_Folders.SubFolders
For Each j In FS_subFolders
Set FS_Folders = FS.GetFolder(j.Path)
colFolders_1.Add j.Path
Set FS_Files = FS_Folders.Files
DoEvents
For Each k In FS_Files
GoSub CheckFileName
Next k
Next j
Next i
If colFolders_1.Count 0 Then
GoTo Start
End If

Exit_Sub:
ThisWorkbook.Save
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

CheckFileName:
If InStr(1, k.Name, "Source") And Right(k, 4) = ".xls" Then
h = h + 1
Set SourceFile = xlApp.Workbooks.Open(k)
Set SourceRange =
SourceFile.Worksheets("CASH").Range ("A1:H100")
For n = 1 To NumRow
For m = 1 To NumCol
TargetRange(n + NumRow * (h - 1), m) = SourceRange(n,
m)
Next
Next
SourceFile.Close
End If
Return

FolderNotFound:
MsgBox "Err. " & Err.Number & " - " & _
Err.Description & vbCrLf & vbLf & _
"Folder: " & UCase(SourceFolder) & _
" -- Not Found."
Resume Exit_Sub

End Sub

Copy range from multiple files in multiple folders to single sheet in master WB
 

Royzer has brought this to us :
Royzer;1603941 Wrote:
Thank you, Bruno. I will try this when I return to work Thursday.

Roy

Bruno, my apologies for taking so long to try your code. If you do not
wish to pursue this after all this time has passed, I understand.

The code on the second line "Dim FS As New FileSystemObject"
is giving me a "user defined type not defined" error:

You need the reference:
MicrosoftScriptingRuntime

These two lines under "CheckFileName" are showing in red when I paste
the code:

Set SourceRange =
Set SourceRange = SourceFile.Worksheets("CASH").Range("A1:H100")
To be written all in one line!

TargetRange(n + NumRow * (h - 1), m) = SourceRange(n,
m)
TargetRange(n + NumRow * (h - 1), m) = SourceRange(n, m)
To be written all in one line!

Bruno

Thank you for your help, Bruno. I made the changes you suggested and now the code runs until it gets to this line in the CheckFileName section:

SourceFile.Worksheets("CASH").Range ("A1:H100")

It gives the error: "Object doesn't support this property or method"

Copy range from multiple files in multiple folders to singlesheet in master WB
 

Hi

As you have already declared the Sourcefile as

Set SourceFile = xlApp.Workbooks.Open(k)

You should only need to use the following:

Set SourceRange = SourceFile.Range("A1:H100")

HTH
Mick.

Thanks, Mick. The code ran but I got jammed with notifications from each of the 32 files I was pulling data from asking me if I wanted to save the file before closing. Is there something I can add to avoid that?

Copy range from multiple files in multiple folders to singlesheet in master WB
 

You could try the following:

In as much as it is purely asthetic, I prefer to use the following which
keeps everything together in a nice collection rather than address each
line of:

Application This, or Application That, you can use the With statement
and include each point.

You would use the following to turn off.

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.AlertBeforeOverwriting = False
End With

Then use this to reset them when exiting the routine.

With Application
.Calculation = = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.AlertBeforeOverwriting = True
End With


HTH
Mick.

Thanks, Mick. I appreciate the help.