Copy all excel files from one folder to another

MPI_IT
MPI_IT used Ask the Experts™
on
I would like to copy all excel files in a folder to another folder using vba code.
I found a vba code which copies excel files from one folder to another, but it does not
copy the files in the subfolders.I will have atleast 2 levels of subfolders .I don't want
to copy the subfolders, only excel files. I have Excel 2007.Any ideas ?
Thanks !
Sub CopyFilesInFolder()

    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim FileExt As String

    FromPath = "C:\L1\Temp\R1"  
    ToPath = "C:\L2\Temp\R2"   

    FileExt = "*.xl*"  
  

    If Right(FromPath, 1) <> "\" Then
        FromPath = FromPath & "\"
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If FSO.FolderExists(ToPath) = False Then
        MsgBox ToPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
    MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

Open in new window

Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Commented:
Are you set on using Excel to do this?
If not, look for Sweep here http://users.csc.calpoly.edu/~bfriesen/software/console.shtml
Extract sweep.exe to the desired folder, open command windows to this folder, and run sweep copy *.xls destination_folder
Done
Lee

Commented:
Sorry, you only need 1 command window, not windows. :-|
Lee
are your subfolders fixed? i.e their names dont change or do you need it to dynamically search and check for subfolders?
Exploring SharePoint 2016

Explore SharePoint 2016, the web-based, collaborative platform that integrates with Microsoft Office to provide intranets, secure document management, and collaboration so you can develop your online and offline capabilities.

Author

Commented:
No,  only the main folder name is fixed
You can use XCOPY via VBA

Path1 is your source path
Path2 the destination

The XCOPY syntax below will copy all .xls files that occur in any folder under Path1 to the same directory structure to Path2

Cheers
Dave

Sub FolderSync2()
    Dim Path1 As String, Path2 As String
    Path1 = "C:\temp\*.xls*"
    Path2 = "C:\aa"
    Call XcopyFiles(Path1, Path2)
End Sub
Sub XcopyFiles(strSource, strDestination)
    Set wsh = CreateObject("wscript.shell")
    wsh.Run "xcopy.exe """ & strSource & """ """ & strDestination & """ /d /s /e /y /h /r", 1, True
    Set wsh = Nothing
End Sub

Open in new window

Commented:
RE: You can use XCOPY via VBA
The OP specifically said no subfolders, only the .xls files. XCOPY has no swtich for this. It either copies from only the current folder OR copies from the current folder and all subfolders INCLUDING the subfolder structure.
My first post asked "Are you set on using Excel to do this?" I understand sometimes our projects dictate certain ways to do things. If you do not need or want to use Excel VBA, my first post gives exactly what you need.
Lee
The XCOPY method below using VBA as requested will copy into a single folder

Please change your two paths here

 strSource = "C:\temp"
 strDest = "C:\new"

Cheers

Dave

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
    Dim j As Long
    Dim MyFile As String
    Dim strSource As String
    Dim strDest As String
    strSource = "C:\temp"
    strDest = "C:\new"
    ReDim Arr(0)
    Arr(0) = strSource
    Arr = GetSubFolders(strSource)
    Application.ScreenUpdating = False
    For j = LBound(Arr) To UBound(Arr)
        Call XcopyFiles(Arr(j) & "\*.xls*", strDest)
    Next j
    Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
    Dim fso As Object
    Dim fld As Object
    Dim sf As Object
    Dim myArr
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(RootPath)
    For Each sf In fld.SUBFOLDERS
        Counter = Counter + 1
        ReDim Preserve Arr(Counter)
        Arr(Counter) = sf.Path
        myArr = GetSubFolders(sf.Path)
    Next
    GetSubFolders = Arr
    Set sf = Nothing: Set fld = Nothing: Set fso = Nothing
End Function
Sub XcopyFiles(strSource, strDestination)
    Set wsh = CreateObject("wscript.shell")
    wsh.Run "xcopy.exe """ & strSource & """ """ & strDestination & """ /y /r", 1, True
    Set wsh = Nothing
End Sub

Open in new window

Author

Commented:
Sorry I did not answer to Lee.
I prefer Vba code, but I will try that too.
Thanks Dave for the code, I will try and let you know.
Thank you both for your response.

Commented:
No problem.
Sometimes, we HAVE to do things a certain way. We cannot do much about that.
Sometimes, we WANT to do things a certain way, sometimes for learning and sometimes just because.
Even though your OP specified "using vba code", I posted my solution because sometimes we do not have the time or it is just not worth the effort.
:-)
Lee

Author

Commented:
Lee's code works. But, I cannot use that in this case.
I want to use a macro instead. Thank you Lee for your contribution.
Dave,
I tried your code. I get compile error : Variable not defined at this line
ReDim Preserve Arr(Counter)
Let me know how to fix it.
Thanks!
I added Option Explicit to test if anything hadn't been defined properly, only the wsh object needed an update. So I am in a bind as to why you are getting the error

Can you pls retry below

Lee,

Agree that its worth proposing different ideas

One thing to bear to mind here is that we tend to refer to people using EE as Askers rather than the more distant OP label common in the newsgroups. It reflects the sense of community here :)

Cheers

Dave

Option Explicit
Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
    Dim j As Long
    Dim MyFile As String
    Dim strSource As String
    Dim strDest As String
    strSource = "C:\temp"
    strDest = "C:\new"
    ReDim Arr(0)
    Arr(0) = strSource
    Arr = GetSubFolders(strSource)
    Application.ScreenUpdating = False
    For j = LBound(Arr) To UBound(Arr)
        Call XcopyFiles(Arr(j) & "\*.xls*", strDest)
    Next j
    Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
    Dim fso As Object
    Dim fld As Object
    Dim sf As Object
    Dim myArr
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(RootPath)
    For Each sf In fld.SUBFOLDERS
        Counter = Counter + 1
        ReDim Preserve Arr(Counter)
        Arr(Counter) = sf.Path
        myArr = GetSubFolders(sf.Path)
    Next
    GetSubFolders = Arr
    Set sf = Nothing: Set fld = Nothing: Set fso = Nothing
End Function
Sub XcopyFiles(strSource, strDestination)
Dim wsh As Object
    Set wsh = CreateObject("wscript.shell")
    wsh.Run "xcopy.exe """ & strSource & """ """ & strDestination & """ /y /r", 1, True
    Set wsh = Nothing
End Sub

Open in new window

Author

Commented:
Dave,
Thanks for the update.
The code runs fine. But, I noticed one problem.
My source folder is C:\L1\Temp\R1 and
my destination folder is C:\L1\Temp\R2.
When I run it first time on that directory, it worked fine and it is fast.
When I run it again with the same source folder , it is very slow and it copied all excel files from C:\ also.
It did not copy from L1 or Temp folders, only from C:\
Is there any reason to it ?
Thanks !

Author

Commented:
Any updates ?

Author

Commented:
Hi ,
I noticed, when I close the excel file each time and run again it works fine.So, I am thinking some variable/file initialization...Thought of just adding it as one step towards figuring it out why. If anybody know,please let me know.
Thanks!
This version ensures that the public counter variable is zeroed each time the code runs>

How does this perform?

Cheers

Dave

Option Explicit
Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
    Dim j As Long
    Dim MyFile As String
    Dim strSource As String
    Dim strDest As String
    strSource = "C:\temp"
    strDest = "C:\new"
    ReDim Arr(0)
    Counter = 0
    Arr(0) = strSource
    Arr = GetSubFolders(strSource)
    Application.ScreenUpdating = False
    For j = LBound(Arr) To UBound(Arr)
        Call XcopyFiles(Arr(j) & "\*.xls*", strDest)
    Next j
    Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
    Dim fso As Object
    Dim fld As Object
    Dim sf As Object
    Dim myArr
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(RootPath)
    For Each sf In fld.SUBFOLDERS
        Counter = Counter + 1
        ReDim Preserve Arr(Counter)
        Arr(Counter) = sf.Path
        myArr = GetSubFolders(sf.Path)
    Next
    GetSubFolders = Arr
    Set sf = Nothing: Set fld = Nothing: Set fso = Nothing
End Function
Sub XcopyFiles(strSource, strDestination)
Dim wsh As Object
    Set wsh = CreateObject("wscript.shell")
    wsh.Run "xcopy.exe """ & strSource & """ """ & strDestination & """ /y /r", 1, True
    Set wsh = Nothing
End Sub

Open in new window

Author

Commented:
Dave,
It works great ! Thank you so much for your effort and help.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial