Copy all excel files from one folder to another

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

MPI_ITAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

lee555J5Commented:
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
0
lee555J5Commented:
Sorry, you only need 1 command window, not windows. :-|
Lee
0
shahzadbuxCommented:
are your subfolders fixed? i.e their names dont change or do you need it to dynamically search and check for subfolders?
0
CompTIA Network+

Prepare for the CompTIA Network+ exam by learning how to troubleshoot, configure, and manage both wired and wireless networks.

MPI_ITAuthor Commented:
No,  only the main folder name is fixed
0
DaveCommented:
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

0
lee555J5Commented:
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
0
DaveCommented:
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

0
MPI_ITAuthor 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.
0
lee555J5Commented:
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
0
MPI_ITAuthor 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!
0
DaveCommented:
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

0
MPI_ITAuthor 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 !
0
MPI_ITAuthor Commented:
Any updates ?
0
MPI_ITAuthor 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!
0
DaveCommented:
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

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
MPI_ITAuthor Commented:
Dave,
It works great ! Thank you so much for your effort and help.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.