Macro to copy all .xls files from folders and sub-folders

[Gaura215]

Hello All

I have gone through several threads. One of that was quite close: http://www.mrexcel.com/forum/excel-...erent-subfolders-dest-folder-rename-file.html

However, I have a slight different problem.

I have a folder for year 2013, which will be 2014 obviously next year. This folder contains multiple subfolder, and further subfolders in each of them, and so on. My objective is to copy all the excel files in folder "2013" irrespective of which subfolder it is lying into. And want to copy all those .xls files in a seperate folder which I will create on my desktop. The names of the excel files can be same or may be different.

I want to know if there is a way out to this. Please be noted, as mentioned above, that there may be more than 1 file with same name in few of these subfolders. So can our macro automatically give a suffix to the file in the destination folder. For example, 3 files in Directory "2013" with name "AAA". Can the macro save these three files as "AAA", "AAA_1" & "AAA_2". Alternatively, I am fine with it, if the files are saved with the path name from where they have been copied.

Any help in this would be highly appreciable. Please let me know if more details needs to be furnished here.

 

[xenou]

Hi,
this code should work. Our strategy is to separate the task into two parts, first to get a list of all the filepaths, then to go through the list and copy the Excel files:

[COLOR="Navy"]Sub[/COLOR] Copy_Excel_Files()

[COLOR="Navy"]Dim[/COLOR] a, b() [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] Long, j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sFolderSource [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sFolderDestination [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] sPath [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] FSO [COLOR="Navy"]As[/COLOR] FileSystemObject
[COLOR="Navy"]Dim[/COLOR] col [COLOR="Navy"]As[/COLOR] VBA.Collection
[COLOR="Navy"]Dim[/COLOR] wb [COLOR="Navy"]As[/COLOR] Workbook

    [COLOR="SeaGreen"]'//Variables and objects[/COLOR]
    sFolderSource = "C:\myTemp"
    sFolderDestination = "C:\users\username\Desktop\TEST"
    [COLOR="Navy"]Set[/COLOR] FSO = CreateObject("Scripting.FileSystemObject")
    [COLOR="Navy"]Set[/COLOR] col = [COLOR="Navy"]New[/COLOR] VBA.Collection
        
    [COLOR="SeaGreen"]'//Get an array of filepaths in search folder.[/COLOR]
    a = Directory_List(sFolderSource, True, True)
    
    [COLOR="SeaGreen"]'//Copy Excel files to destination folder[/COLOR]
    [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] IsEmpty(a) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]With[/COLOR] FSO
            [COLOR="Navy"]For[/COLOR] i = 0 [COLOR="Navy"]To[/COLOR] UBound(a)
                [COLOR="Navy"]If[/COLOR] InStr(1, a(i), "xls") > 0 [COLOR="Navy"]Then[/COLOR]
                    
                    [COLOR="SeaGreen"]'//Create a save filename[/COLOR]
                    j = 0
                    sPath = sFolderDestination & IIf(Right(sPath, 1) <> "\", "\", "")
                    sPath = sPath & .GetBaseName(a(i))
                    [COLOR="Navy"]Do[/COLOR] [COLOR="Navy"]While[/COLOR] .FileExists(sPath & IIf(j, "_" & Format(j, "000"), "") _
                                & "." & .GetExtensionName(a(i)))
                        j = j + 1
                    [COLOR="Navy"]Loop[/COLOR]
                    sPath = sPath & IIf(j, "_" & Format(j, "000"), "") _
                                & "." & .GetExtensionName(a(i))
                    
                    [COLOR="SeaGreen"]'//Copy file[/COLOR]
                    [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
                    FSO.CopyFile a(i), sPath
                    [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]GoTo[/COLOR] 0
                    
                    [COLOR="SeaGreen"]'//Report errors in copying (if any)[/COLOR]
                    [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] .FileExists(sPath) [COLOR="Navy"]Then[/COLOR]
                        col.Add a(i)
                    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
                
                [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
            [COLOR="Navy"]Next[/COLOR]
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
    
        [COLOR="SeaGreen"]'//Check for errors in copying[/COLOR]
        [COLOR="Navy"]If[/COLOR] col.Count > 0 [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] wb = Workbooks.Add
            [COLOR="Navy"]With[/COLOR] wb.Worksheets(1)
                .Cells(1, 1).Value = "COPY ERRORS"
                [COLOR="Navy"]For[/COLOR] i = 1 [COLOR="Navy"]To[/COLOR] col.Count
                    .Cells(i, 1).Offset(1).Value = col(i)
                [COLOR="Navy"]Next[/COLOR] i
            [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
        [COLOR="Navy"]Else[/COLOR]
            MsgBox "Complete.  No copy errors found.  "
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    
    [COLOR="Navy"]Else[/COLOR]
        MsgBox "No excel files found.  "
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
        
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

You must have these extra functions (in the same code module, most likely):

[COLOR="Navy"]Public[/COLOR] [COLOR="Navy"]Function[/COLOR] Directory_List(ByVal startInFolder [COLOR="Navy"]As[/COLOR] String, _
    [COLOR="Navy"]Optional[/COLOR] includeImmediateSubFolders [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Boolean[/COLOR] = False, _
    [COLOR="Navy"]Optional[/COLOR] includeAllSubFolders [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Boolean[/COLOR] = False) [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Variant[/COLOR]
    [COLOR="SeaGreen"]'---------------------------------------------------------------------------------[/COLOR]
    [COLOR="SeaGreen"]'   Directory_List public function (exposed function)[/COLOR]
    [COLOR="SeaGreen"]'   Returns: Variant/Array if at least one file is found, Variant/Empty otherwise.[/COLOR]
    [COLOR="SeaGreen"]'---------------------------------------------------------------------------------[/COLOR]

[COLOR="Navy"]Dim[/COLOR] a() [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR] [COLOR="SeaGreen"]'//Array to hold filepaths[/COLOR]
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR] [COLOR="SeaGreen"]'//Counter of files found[/COLOR]
[COLOR="Navy"]Dim[/COLOR] FSO [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Object[/COLOR]
    
    [COLOR="Navy"]Set[/COLOR] FSO = CreateObject("Scripting.FileSystemObject")
    [COLOR="Navy"]ReDim[/COLOR] a(0 [COLOR="Navy"]To[/COLOR] 0)
    
    [COLOR="Navy"]Call[/COLOR] Directory_List_Main(FSO, a, i, _
            startInFolder, _
            includeImmediateSubFolders, _
            includeAllSubFolders)
            
    [COLOR="Navy"]If[/COLOR] i > 0 [COLOR="Navy"]Then[/COLOR]
        Directory_List = a
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    
    [COLOR="Navy"]Set[/COLOR] FSO = [COLOR="Navy"]Nothing[/COLOR]
    
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Function[/COLOR]

[COLOR="Navy"]Private[/COLOR] [COLOR="Navy"]Sub[/COLOR] Directory_List_Main(ByRef FSO [COLOR="Navy"]As[/COLOR] Object, [COLOR="Navy"]ByRef[/COLOR] a() [COLOR="Navy"]As[/COLOR] String, [COLOR="Navy"]ByRef[/COLOR] i [COLOR="Navy"]As[/COLOR] Long, _
    [COLOR="Navy"]ByRef[/COLOR] startInFolder [COLOR="Navy"]As[/COLOR] String, _
    [COLOR="Navy"]Optional[/COLOR] includeImmediateSubFolders [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Boolean[/COLOR] = False, _
    [COLOR="Navy"]Optional[/COLOR] includeAllSubFolders [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Boolean[/COLOR] = False)
    [COLOR="SeaGreen"]'---------------------------------------------------------------------------------------[/COLOR]
    [COLOR="SeaGreen"]'   Directory_List_Main private function (iterates files/folders to retrieve filepaths).[/COLOR]
    [COLOR="SeaGreen"]'---------------------------------------------------------------------------------------[/COLOR]

[COLOR="Navy"]Dim[/COLOR] MyFolder [COLOR="Navy"]As[/COLOR] Folder
[COLOR="Navy"]Dim[/COLOR] mySubfolder [COLOR="Navy"]As[/COLOR] Folder
[COLOR="Navy"]Dim[/COLOR] f [COLOR="Navy"]As[/COLOR] File
[COLOR="Navy"]Dim[/COLOR] msg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]

    [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]GoTo[/COLOR] Handler
    
    [COLOR="SeaGreen"]'//Error - initial folder not found[/COLOR]
    [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] (FSO.FolderExists(startInFolder)) [COLOR="Navy"]Then[/COLOR]
        msg = "Error. Folder not Found:" & vbNewLine & startInFolder
        MsgBox msg, vbExclamation
        [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    
    [COLOR="SeaGreen"]'//Process files in folder[/COLOR]
    [COLOR="Navy"]With[/COLOR] FSO
        [COLOR="Navy"]Set[/COLOR] MyFolder = .GetFolder(startInFolder)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] f [COLOR="Navy"]In[/COLOR] MyFolder.Files
            [COLOR="Navy"]ReDim[/COLOR] [COLOR="Navy"]Preserve[/COLOR] a(0 [COLOR="Navy"]To[/COLOR] i)
            a(i) = f.Path
            i = i + 1
        [COLOR="Navy"]Next[/COLOR] f
        
        [COLOR="SeaGreen"]'//optional recursive call(s) for subfolder(s)[/COLOR]
        [COLOR="Navy"]If[/COLOR] (includeImmediateSubFolders [COLOR="Navy"]Or[/COLOR] includeAllSubFolders) [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] mySubfolder [COLOR="Navy"]In[/COLOR] MyFolder.SubFolders
                [COLOR="Navy"]Call[/COLOR] Directory_List_Main(FSO, a, i, _
                        mySubfolder.Path, _
                        includeAllSubFolders, _
                        includeAllSubFolders)
            [COLOR="Navy"]Next[/COLOR] mySubfolder
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]

My_Exit:
[COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Handler:
MsgBox "Error in Sub Directory_List_Main" & Err.Number & " " & Err.Description
[COLOR="Navy"]Set[/COLOR] FSO = [COLOR="Navy"]Nothing[/COLOR]
[COLOR="Navy"]Resume[/COLOR] My_Exit

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

This is based on the code published at my site:
Recursive Folder Search

Similar, as it turns out to this code here:
Recursive Folder Search - Find Files in Subdirectories - Access Image FAQ

 

[Gaura215]

Thanks a lot xenou for your time on this.

However, I have moved on to next step already in my requirement. I have been able to extract the relevant data from all those files to my master sheet. And they are getting captured from coloumn B onwards. Where I am stuck now is that, I am not able to understand the source file of the data which have been copied.
What I need now is that coloum A in each row reflects the full file name from where the data has been copied. So, I will have the sourece in coloum A from where Data in coloum B onwards have been copied from.

Hope I am able to explain it.

Following is the code I am currently using:

Sub AAA()
Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim SubF As Scripting.Folder

Set FSO = New Scripting.FileSystemObject
Set FF = FSO.GetFolder("C:\Users\g.khanna\Desktop\Recons\Spain\")
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub

Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.file
Dim SubF As Scripting.Folder
Dim WB As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False

For Each F In FF.Files
Set WB = Workbooks.Open(F.Path)
' select data from open workbook
Sheets("Open items").Select
ActiveSheet.Unprotect Password:="trunte"
Range("A15000").Select
ActiveCell.FormulaR1C1 = "NON"
Range("A9:I9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Windows("ADC Final.xlsm").Activate
Range("B2").Select
'find the next empty row
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
WB.Close SaveChanges:=False
Debug.Print F.Name
Next F

For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub

 

[Pendrigh]

This is an old thread but just to add: I have found that Bulk Rename Utility (<cite class="_Rm">www.[B]bulkrenameutility[/B].co.uk/) </cite>is an effective way of moving and renaming files - for example, it allows you to select files in a folder, regardless of subfolder, and move and rename them. (I don't have any personal interest in this product - I have simply used it). The user interface gives a large number of options. There are probably other similar utilities out there.

 

[robmaag]

Hi, This is create code but I am getting an error on the following lines:

Dim FSO As FileSystemObject

Dim MyFolder As Folder


For both of these I am getting the following error:
Compile Error: User-defined type not defined

Please help.

 

[robmaag]

Hi, I have found another error:

includeImmediateSubFolders

Error Message: ByRef argument type mismatch

This where I am getting the error message:

Public Function Directory_List(ByVal startInFolder As String, _
Optional includeImmediateSubFolders As Boolean = False, _
Optional includeAllSubFolders As Boolean = False) As Variant
'---------------------------------------------------------------------------------
' Directory_List public function (exposed function)
' Returns: Variant/Array if at least one file is found, Variant/Empty otherwise.
'---------------------------------------------------------------------------------
Dim a() As String '//Array to hold filepaths
Dim i As Long '//Counter of files found
Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemObject")
ReDim a(0 To 0)

Call Directory_List_Main(FSO, a, i, _
startInFolder, _
includeImmediateSubFolders, _
includeAllSubFolders)