Ron de Bruin's code "Copy a range from all files in a folder and subfolders (optional)" ???

[Mark Ivey]

Ron,

Please excuse this post if you did receive my email...

*************************************************************

I have been trying to figure out Ron de Bruin's code "Copy a range from all
files in a folder and subfolders (optional)" at
http://www.rondebruin.nl/ado.htm

I have emailed Ron, but he may be unavailable for the holidays (I am not
sure)...

It appears to do what Ron said it would do, but it will only go ONE level
deep into the subfolders. I would like it to go into all subfolder levels (I
have at least three levels of depth to my subfolder structure). Does anyone
know what needs to be changed with his code to make it go any deeper in the
folder structure?

Many thanks in advance for your help...

Mark Ivey

 

[Ron de Bruin]

Hi Mark

I will update the code soon

See Chip's reply in a thread about this

Sub CopyTheFiles()
Dim FSO As Scripting.FileSystemObject
Dim RD As Scripting.Folder
Dim FF As Scripting.Folder
Dim F As Scripting.File


Set FSO = New Scripting.FileSystemObject
Set RD = FSO.GetDrive("G").RootFolder
For Each FF In RD.SubFolders
DoOneFolder WhatFolder:=FF
Next FF
End Sub


Sub DoOneFolder(WhatFolder As Scripting.Folder)
Dim F As Scripting.File
Dim FF As Scripting.Folder
Set F = WhatFolder.Files("TheFileName.xls")
F.Copy Destination:="C:\Whatever\" & F.Name


For Each FF In WhatFolder.SubFolders
DoOneFolder WhatFolder:=FF
Next FF
End Sub


See also http://www.cpearson.com/Excel/RecursionAndFSO.htm for example code.

 

[Ron de Bruin]

Hi Mark, I will try update the page tomorrow.
Check it out tomorrow
The last months are heavy, my father past away in Oct and to much work the last weeks
to be in the newsgroups or work on my site.

 

[Mark Ivey]

Ron,

I am very sorry to hear about your father.

I do appreciate your help very much.

Thank you...

Mark Ivey

 

[Ron de Bruin]

Hi Mark

Can you test this tester for me
See the new sub I add now named ListFilesInSubfolders

Will also update the getdata macro for Excel 2007 files and update the site tomorrow

Delete the old macro named GetData_Example7 and copy this
in a normal module (3 dim strings at the top of the module)


Dim MyFiles() As String
Dim Fnum As Long
Dim FileExt As String


Sub GetData_Example7()
'Copy cells from folder and subfolder(s)
Dim Subfolders As Boolean
Dim Fsbj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
Dim RootPath As String
Dim sh As Worksheet, destrange As Range
Dim rnum As Long

'Loop through all files in the Root folder
RootPath = "C:\Users\Ron\Test"

'Loop through the subfolders True or False
Subfolders = True

'Loop through files with this extension (*.xl* is all excel files)
FileExt = "*.xl*"

'Add a slash at the end if the user forget it
If Right(RootPath, 1) <> "\" Then
RootPath = RootPath & "\"
End If

Set Fsbj = CreateObject("Scripting.FileSystemObject")
If Not Fsbj.FolderExists(RootPath) Then
MsgBox RootPath & " Not exist"
Exit Sub
End If

Set RootFolder = Fsbj.GetFolder(RootPath)

'Fill the array(myFiles)with the list of Excel files in the folder(s)
Erase MyFiles()
Fnum = 0

'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = RootPath & file.Name
End If
Next file

'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders Then
Call ListFilesInSubfolders(OfFolder:=RootFolder)
End If

' Now we can loop through the files in the array MyFiles to get the cell values
'******************************************************************

'Add worksheet to the Activeworkbook and use the Date/Time as name
Set sh = ActiveWorkbook.Worksheets.Add
sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "A")

' Copy the workbook name in Column E
sh.Cells(rnum + 1, "E").Value = MyFiles(Fnum)

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyFiles(Fnum), "Sheet1", "A1:C1", destrange, False, False

Next
End If
End Sub


Sub ListFilesInSubfolders(OfFolder As Object)
'Origenal SubFolder code from Chip Pearson
'http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by ron de Bruin, 23-Dec-2007
Dim SubFolder As Object
Dim fileInSubfolder As Object

For Each SubFolder In OfFolder.Subfolders
ListFilesInSubfolders OfFolder:=SubFolder

For Each fileInSubfolder In SubFolder.Files
If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
End If
Next fileInSubfolder

Next SubFolder
End Sub

 

[Mark Ivey]

That works like a charm...

Thank you very much for your support on this item.

I hope you have a very Merry Christmas.


Mark Ivey

 

[Ron de Bruin]

Thanks for testing Mark

I update the function also for Excel 2007 files and change the function to late binding
Check out my page tomorrow

I hope you have a very Merry Christmas.

Same to you

 

[Ron de Bruin]

The new ADO page is online now
http://www.rondebruin.nl/ado.htm

 

[Mark Ivey]

Ron,

Thanks again for your help on this item...

I do have one question for you.

I am actually copying three individual cells using your code. But if I use a
single cell reference as a Range in your code, it will not pull any data.

Example: GetData MyFiles(Fnum), "Sheet 1", "C5", destrange, False, False

It has to be listed like this:

Example 2: GetData MyFiles(Fnum), "Sheet 1", "C5:C5", destrange, False,
False

I don't mind using it this way, but I was under the impression you could
specify a range using a single cell reference. It must have something to do
with the next portion of code that deals with the ADO connection. I am not
sure.

Here is a snippet of how I am using your code:

1st I added the new variables

Dim sh As Worksheet, destrange As Range, destrange2 As Range, destrange3 As
Range

Then I changed up the reference points to get just what I needed to build a
summary page:

For Fnum = LBound(MyFiles) To UBound(MyFiles)

'Find the last row with data
rnum = LastRow(sh)

'create the destination cell address
Set destrange = sh.Cells(rnum + 1, "B")
Set destrange2 = sh.Cells(rnum + 1, "C")
Set destrange3 = sh.Cells(rnum + 1, "A")

'Get the cell values and copy it in the destrange
'Change the Sheet name and range as you like
GetData MyFiles(Fnum), "Sheet 1", "C5:C5", destrange, False,
False
GetData MyFiles(Fnum), "Sheet 1", "G25:G25", destrange2, False,
False
GetData MyFiles(Fnum), "Sheet 1", "E3:E3", destrange3, False,
False

Next


Just curious....


Mark Ivey

 

[Ron de Bruin]

Read the notes on the page Mark

Important info about the ADO examples

1) The code in the workbook is working in Excel 2000-2007.

2) In a Database you cannot mix data types, a column must be all numbers or all text. If there
are different data types in the column ADO will copy only the Data type that have the majority.

3) If you want to copy only one cell from each workbook then use A3:A3 and not A3 in the code.

 

[Mark Ivey]

My bad....

I must have overlooked that instruction item...

Thanks again for all your help Ron


I hope you have a very Merry Christmas.

Mark Ivey