View Single Post
  #5   Report Post  
Royzer Royzer is offline
Junior Member
 
Posts: 21
Default

Quote:
Originally Posted by Royzer View Post
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