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

[Royzer]

I have 30 files, each in a different folder on a network drive. I nee
to be able to copy the top 100 rows from the first sheet of each fil
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 sheet
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 nee
to copy this range from share the word "Source" in the workbook name.Th
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 th
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 bee
copied and pasted the file would automatically save. Some director
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 t
find a solution to this anywhere.

Thanks

 

[Don Guillett]

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!

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

 

[Bruno Campanini]

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

 

[Royzer]

;1603861']Royzer brought next idea :-

I have 30 files, each in a different folder on a network drive. 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 monthl basis.
(If that is not possible, I guess I could copy them to separat sheets
and link all of the sheets to a "master" sheet in my maste workbook.)

There are other Excel files in these directories, but the files need
to copy this range from share the word "Source" in the workboo 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.

Ro

 

[Royzer]

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 no
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 past
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 Su

 

[Bruno Campanini]

Royzer has brought this to us :

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

 

[Royzer]

;1604991']Royzer has brought this to us :-

Royzer;1603941 Wrote: -

Bruno, my apologies for taking so long to try your code. If you d 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 no
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

 

[Living the Dream]

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.

 

[Royzer]

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 eac
of the 32 files I was pulling data from asking me if I wanted to sav
the file before closing. Is there something I can add to avoid that

 

[Living the Dream]

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.

 

[Royzer]

You could try the following:

In as much as it is purely asthetic, I prefer to use the following whic

keeps everything together in a nice collection rather than address eac

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