PDA

View Full Version : Copying files from FromPath to ToPath VBA Code inclduing sub directories



trpkob
01-07-2013, 01:31 PM
I have been working with the code below which copies files from FromPath to ToPath within the past 30 days with the FromPath and ToPath being defined in cells F4 and F5 respectively.

I need it to be able to copy files within sub directories as well sub directories if they do not exist, not just straight files within the location. So if the FromPath has a directory called A and has a file within it called 1.txt that was modified within the past 30 days I need that to be copied to the ToPath as well and for other directories within directories. So if sub directory A had a sub directory B and so forth I need that taken into account as well.

Sub Copy_Files()

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object

FromPath = Worksheets("1").Range("F4").Value2
ToPath = Worksheets("1").Range("F5").Value2

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

If Right(ToPath, 1) <> "\" Then
ToPath = ToPath & "\"
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

For Each FileInFromFolder In FSO.getfolder(FromPath).Files
Fdate = Int(FileInFromFolder.DateLastModified)
If Fdate >= Date - 30 Then
FileInFromFolder.Copy ToPath
End If
Next FileInFromFolder

MsgBox "You can find the files from " & FromPath & " in " & ToPath

End Sub

Kenneth Hobs
01-07-2013, 01:45 PM
How will you handle name collisions?
e.g.
c:\s1\ken.xlsm
c:\s1\s2\ken.xlsm

trpkob
01-07-2013, 01:51 PM
Those are in two different sub directories so there should not be a collision, one is in the s1 sub directory and the other is in the s2 sub directory.

snb
01-07-2013, 02:51 PM
did you try :

sub M_snb()
CreateObject("scripting.filesystemobject").copyfolder Worksheets("1").Range("F4").Value,Worksheets("1").Range("F5").Value
end sub

trpkob
01-07-2013, 02:56 PM
snb, that works but does not take into account the modification dates. I don't want it to copy everything over but rather files that were modified within a certain time frame.

snb
01-07-2013, 02:58 PM
You won't notice the difference, so why bother ?

trpkob
01-07-2013, 03:01 PM
snb, time is a factor. The directory contains many GB worth of files and copying them all over each time is quite time consuming especially sense it is on a network.

Kenneth Hobs
01-07-2013, 05:14 PM
A shell to XCopy would be one method. IF you don't know the command line switches to pass, do a Start > Run > CMD > OK > Help XCOPY > Exit.

snb
01-08-2013, 01:50 AM
Did you consider to use e.g. allwaysync ?

see:
http://allwaysync.com/download.html

trpkob
01-08-2013, 06:29 AM
Thanks Kenneth and snb! No way to use VBA code to accomplish this then?

Kenneth Hobs
01-08-2013, 06:47 AM
There are many ways to do it in VBA.

I gave one of the easier methods. Do it manually on a test folder first as I explained and then use that xcopy string in Shell(). If I get time tonight, I will give you a full VBA example.

Your method just needs tweaked first to get all files which we have several threads that show that method. I have a routine similar to that but iterates the subfolders. A Shell method can be used using the command shell's DIR command.

e.g.
' /b = bare file listing, /s = search subfolders, /c = open command shell, run command and then close shell.
' /a:-d means list files only and not subfolders
s = CreateObject("Wscript.Shell").Exec("cmd /c dir x:\test\*.* /a:-d /b").StdOut.ReadAll

trpkob
01-08-2013, 06:53 AM
Thanks Kenneth. A full VBA example would be very beneficial! I will play around with xcopy string in Shell().

Kenneth Hobs
01-08-2013, 07:06 AM
Here is a link to an fso method to list files.

http://www.ozgrid.com/forum/showthread.php?t=157939

I used it like this once. Note that debug.print prints to VBE's Immediate window.
Sub Test_SearchFiles()
Dim v As Variant, a() As Variant
SearchFiles ThisWorkbook.Path, "*.xls", 0, a(), True
For Each v In a()
Debug.Print v
Next v
End Sub


Private Function SearchFiles(myDir As String _
, myFileName As String, n As Long, myList() _
, Optional SearchSub As Boolean = False) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(myDir).Files
Select Case myFile.Attributes
Case 2, 4, 6, 34
Case Else
If (Not myFile.Name Like "~$*") _
* (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
* (UCase(myFile.Name) Like UCase(myFileName)) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = myDir
myList(2, n) = myFile.Name
End If
End Select
Next
If SearchSub Then
For Each myFolder In fso.getfolder(myDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, _
n, myList, SearchSub)
Next
End If
SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function

snb
01-08-2013, 07:22 AM
Includig subfolders in G:\OF\
Copying from G:\OF\ to Q:\OF\

Sub M_snb()
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir G:\OF\*.* /b /s").stdout.readall, vbCrLf), "\")
For j = 0 To UBound(sn)
If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
Next

sn = Filter(sn, "\")

For j = 0 To UBound(sn)
FileCopy sn(j), "Q" & Mid(sn(j), 2)
Next
End Sub

trpkob
01-09-2013, 06:42 AM
Where would I specify the source and destination? Say C:\Documents and Settings\Home\Desktop\New Folder to C:\Documents and Settings\Home\Desktop\New Folder (2) for example?


Includig subfolders in G:\OF\
Copying from G:\OF\ to Q:\OF\

Sub M_snb()
sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir G:\OF\*.* /b /s").stdout.readall, vbCrLf), "\")
For j = 0 To UBound(sn)
If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
Next

sn = Filter(sn, "\")

For j = 0 To UBound(sn)
FileCopy sn(j), "Q" & Mid(sn(j), 2)
Next
End Sub

snb
01-09-2013, 07:04 AM
Sub M_snb()


sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir C:\Documents and Settings\Home\Desktop\New Folder\*.* /b /s").stdout.readall, vbCrLf), "\")

For j = 0 To UBound(sn)
If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
Next


sn = Filter(sn, "\")


For j = 0 To UBound(sn)
FileCopy sn(j), "C:\Documents and Settings\Home\Desktop\New Folder (2)\" & dir(sn(j))
Next
End Sub

trpkob
01-09-2013, 07:10 AM
That is what I tried and it does not do anything, a blank command prompt window flashes for a second and that is it, the files never copy over.



Sub M_snb()


sn = Filter(Split(CreateObject("wscript.shell").exec("cmd /c dir C:\Documents and Settings\Home\Desktop\New Folder\*.* /b /s").stdout.readall, vbCrLf), "\")

For j = 0 To UBound(sn)
If DateDiff("d", FileDateTime(sn(j)), Date) > 30 Then sn(j) = ""
Next


sn = Filter(sn, "\")


For j = 0 To UBound(sn)
FileCopy sn(j), "C:\Documents and Settings\Home\Desktop\New Folder (2)\" & dir(sn(j))
Next
End Sub

snb
01-09-2013, 07:20 AM
You can step through the code F8 and check the values of the several variables.

I can't check whter your system contains the directories you specified.
I wouldn't use ' ... (2)\ ..." in a foldername; try something without brackets and spaces.

trpkob
01-09-2013, 07:30 AM
I changed my folder names to Test and Test2 and the values of the variables show sn= -1, sn(j) = <Subscript out of range>, and j= 0


You can step through the code F8 and check the values of the several varaibles.

I can't check whter your system contains the directories you specified.
I wouldn't us ' ... (2)\ ..." in a foldername; try something without brackets and spaces.

snb
01-09-2013, 07:45 AM
Does the folder \Test\ contain any files ?

trpkob
01-09-2013, 07:46 AM
Yes, its is not Q:\Test\ but C:\Documents and Settings\Home\Desktop\Test\


Does the folder Q:\Test\ contain any file ?

snb
01-09-2013, 07:57 AM
what's the result of
MsgBox Dir("C:\Documents and Settings\Home\Desktop\Test\*.*")

Do you use windows XP ?

Kenneth Hobs
01-09-2013, 08:37 AM
Here is my xcopy example. It creates the subfolders in the target folder and puts the source files in them though. This is how I backup files.

I also included another way to get help for xcopy and a link to the resource kit that has the more powerful robocopy.exe.

'xcopy help, http://pcsupport.about.com/od/commandlinereference/p/xcopy-command.htm
' robocopy, https://www.microsoft.com/en-us/download/confirmation.aspx?id=17657

Sub XCopy30()
Dim d As Date, s As String, t As String
s = "x:\t"
t = "x:\tt"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = "xcopy " & s & " " & t & " /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)
'Debug.Print s

Shell s, vbHide
End Sub

trpkob
01-09-2013, 10:33 AM
The result of the message box is nothing, it pops up with a blank display. Yes it is Windows XP.


what's the result of
MsgBox Dir("C:\Documents and Settings\Home\Desktop\Test\*.*")
Do you use windows XP ?

trpkob
01-09-2013, 10:39 AM
Thanks Kenneth, I tired this out setting it up to grab the file locations from a cell as well as hard typing them in and it does not do anything. Am I missing something?


Sub XCopy30()
Dim d As Date, s As String, t As String
s = Worksheets("1").Range("F4").Value2
t = Worksheets("1").Range("F5").Value2
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = "xcopy " & s & " " & t & " /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)
'Debug.Print s

Shell s, vbHide
End Sub



Sub XCopy30()
Dim d As Date, s As String, t As String
s = "C:\Documents and Settings\Home\Desktop\Test"
t = "C:\Documents and Settings\Home\Desktop\Test2"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = "xcopy " & s & " " & t & " /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)
'Debug.Print s

Shell s, vbHide
End Sub



Here is my xcopy example. It creates the subfolders in the target folder and puts the source files in them though. This is how I backup files.

I also included another way to get help for xcopy and a link to the resource kit that has the more powerful robocopy.exe.

'xcopy help, http://pcsupport.about.com/od/commandlinereference/p/xcopy-command.htm
' robocopy, https://www.microsoft.com/en-us/download/confirmation.aspx?id=17657

Sub XCopy30()
Dim d As Date, s As String, t As String
s = "x:\t"
t = "x:\tt"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = "xcopy " & s & " " & t & " /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)
'Debug.Print s

Shell s, vbHide
End Sub

Kenneth Hobs
01-09-2013, 12:20 PM
Uncomment the debug.print line to see the string in VBE's Immediate window when you play it.

Step through the code with F8 if needed.

I suspect that none meet the date criterion since it works fine for me or it is as described below.

When using shell commands, you may need to encapsulate your path strings with quote characters if they have space characters. You can test to see what the command shell does with the string if you paste it or type the string. That is why I like to put the string into the Immediate Window. I explained how to get to the cmd shell earlier.

e.g.
s = "xcopy """ & s & """ """ & t & """ /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)

trpkob
01-09-2013, 07:39 PM
I got things working; it does not like to take spaces within the path names so “Documents and Settings” was the issue. A path name such as “D:\Test” works. Thank you for all your help Kenneth! It is greatly appreciated!


Uncomment the debug.print line to see the string in VBE's Immediate window when you play it.

Step through the code with F8 if needed.

I suspect that none meet the date criterion since it works fine for me or it is as described below.

When using shell commands, you may need to encapsulate your path strings with quote characters if they have space characters. You can test to see what the command shell does with the string if you paste it or type the string. That is why I like to put the string into the Immediate Window. I explained how to get to the cmd shell earlier.

e.g.
s = "xcopy """ & s & """ """ & t & """ /s/D:" & Month(d) & "-" & Day(d) & "-" & Year(d)

trpkob
01-09-2013, 07:42 PM
Thank you Kenneth and snb for all your help! Hopefully everything runs smoothly.

snb
01-10-2013, 02:43 AM
Did some polishing & internationalising;
NB. the 'to' folder can't be a subfolder of the 'from' folder.
Still no solution for paths that contain spaces, though: I tried to use `, ' or chr(34) to wrap the path in, to no avail.

Sub M_backup_snb()
c00 = "G:\OF" ' from
c01 = "G:\bakkup" ' to
c02 = 20 ' since

If Dir(c00, 16) = "" Or InStr(c01, c00) Then Exit Sub
If Dir(c01, 16) = "" Then MkDir c01

Shell "xcopy " & c00 & Space(1) & c01 & " /s /d:" & FormatDateTime(Date - c02, 0), 0
End Sub

Kenneth Hobs
01-10-2013, 07:19 AM
Using double quotes is an easy way to do it but not always intuitive. Sometimes I set q="""" and use that to encapsulate strings. Of course a function works fine too and lets you not worry if it was encapsulated already or not.

e.g.
Sub XCopy2()
Dim d As Date, s As String, t As String
s = "x:\t"
t = "x:\t t"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = Quote(s)
t = Quote(t)
s = "xcopy " & s & " " & t & " /y/k/o/s/D:" & Format(d, "m-d-yyyy")

Debug.Print s

Shell s, vbHide
End Sub

Function Quote(str As String) As String
If Left(str, 1) = """" Then
Quote = str
Else: Quote = """" & str & """"
End If
End Function

trpkob
01-10-2013, 05:07 PM
The issue I am seeing is that it does not overwrite existing data if it has been updated. Also, tt only copies over any new files in the main directory, it does not copy over files that may have been created in sub directories. If a sub directory already exists in the destination and the source location has had files added/changed/modified these are not copied over.


Using double quotes is an easy way to do it but not always intuitive. Sometimes I set q="""" and use that to encapsulate strings. Of course a function works fine too and lets you not worry if it was encapsulated already or not.

e.g.
Sub XCopy2()
Dim d As Date, s As String, t As String
s = "x:\t"
t = "x:\t t"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = Quote(s)
t = Quote(t)
s = "xcopy " & s & " " & t & " /y/k/o/s/D:" & Format(d, "m-d-yyyy")

Debug.Print s

Shell s, vbHide
End Sub

Function Quote(str As String) As String
If Left(str, 1) = """" Then
Quote = str
Else: Quote = """" & str & """"
End If
End Function

snb
01-11-2013, 03:02 AM
Did you consult the links Kenneth provided ?

trpkob
01-11-2013, 02:39 PM
Looks like I have things working for now, I had to add some of the xcopy options. Thanks a lot Kenneth and snb!

trpkob
01-14-2013, 05:12 PM
Is there any way to display Windows copying dialog box while the copying takes place or to have a message box come up saying done when copying is complete? When there are many files being copied it would be helpful to know when the process is complete.


Using double quotes is an easy way to do it but not always intuitive. Sometimes I set q="""" and use that to encapsulate strings. Of course a function works fine too and lets you not worry if it was encapsulated already or not.

e.g.
Sub XCopy2()
Dim d As Date, s As String, t As String
s = "x:\t"
t = "x:\t t"
d = Date - 30

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

If Dir(s, vbDirectory) = "" Then
MsgBox s, vbCritical, "Invalid Folder - Macro Ending"
Exit Sub
End If

s = Quote(s)
t = Quote(t)
s = "xcopy " & s & " " & t & " /y/k/o/s/D:" & Format(d, "m-d-yyyy")

Debug.Print s

Shell s, vbHide
End Sub

Function Quote(str As String) As String
If Left(str, 1) = """" Then
Quote = str
Else: Quote = """" & str & """"
End If
End Function

Kenneth Hobs
01-14-2013, 06:43 PM
Use vbNormal rather than vbHide. MsgBox() can be used after the Shell() but to really wait, you may want to use ShellExecuteWait().

trpkob
01-15-2013, 06:50 AM
vbNormal did not change anything, there is still no display of copying.


Use vbNormal rather than vbHide. MsgBox() can be used after the Shell() but to really wait, you may want to use ShellExecuteWait().

snb
01-15-2013, 07:49 AM
Please do not quote every post !

Use


createobject("wscript.shell").exec "xcopy " & s & " " & t & " /y/k/o/s/D:" & Format(d, "m-d-yyyy")

Kenneth Hobs
01-15-2013, 07:57 AM
Why you need to see that I don't know. Use the maximize parameter of Shell() if you really want to see that. Though it will not show for long.

If you really want a shellandwait, see: www.cpearson.com/Excel/ShellAndWait.aspx (http://www.cpearson.com/Excel/ShellAndWait.aspx)