VBA code to copy files from one location to another based off of creation date

[trpkob]

I am looking to grab every file within a folder (and its subfolders) that were created after the current date and copy them to another location.

For instance let’s say our source location has a folder called A and within that folder we have folders called B C D and within B C D we have 1.txt in B and 2.txt in C and nothing in D that were created today. I want 1.txt and 2.txt to be copied to the destination location which has the same folder structure. The copying is to be dependent on the current date that the code is being run.

[snb]

There are many backup/synchronize programs that do exactly what you want. Why building what already exists ?

[trpkob]

snb, as I need it to be within Excel.

[snb]

so why don't you save any file in 2 places ?


Private Sub Workbook_AfterSave(ByVal Success As Boolean)
thisworkbook.savecopyas "G:\OF\" & thisworkbook.name
End Sub

[trpkob]

Good point, that would only save the Excel file however. I esentailly need synchronize VBA code. I want to save the files that have been updated/added from location A to location B.

[mdmackillop]

Based on this KB code

http://www.vbaexpress.com/kb/getarticle.php?kb_id=405



Option Base 1
Public X()
Public i As Long
Public objShell, objFolder, objFolderItem
Public FSO, oFolder, Fil


Sub test()
Dim MyData
MyData = MainExtractData(BrowseForFolder())
Dim SourceFile, DestinationFile
Dim Dest
Dim Chk
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")

y = Application.Index(MyData, , 3)

For j = 1 To UBound(y)
If y(j, 1) > Date - 7 Then 'Set date check value
SourceFile = MyData(j, 1) & "\" & MyData(j, 2)
Dest = Application.WorksheetFunction.Substitute(MyData(j, 1), "\Users\", "\Test\") 'Alter origanal path to new path

'New folder routine to be added here if required
Chk = fs.folderexists(Dest)
If Chk = False Then
MsgBox "Create folder " & Dest
Exit Sub
End If

DestinationFile = Dest & "\" & MyData(j, 2) ' Define target file name.
FileCopy SourceFile, DestinationFile ' Copy source to target.
End If
Next
End Sub



Function MainExtractData(MainFolderName)

Dim TimeLimit As Long, StartTime As Double

ReDim X(1 To 11, 1 To 100000)

Set objShell = CreateObject("Shell.Application")

Application.ScreenUpdating = False
'MainFolderName = BrowseForFolder()

i = 0

Set FSO = CreateObject("scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(MainFolderName)
'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
On Error Resume Next
For Each Fil In oFolder.Files
Set objFolder = objShell.Namespace(oFolder.Path)
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1

X(1, i) = oFolder.Path
X(2, i) = Fil.Name
X(3, i) = Fil.DateLastAccessed
X(4, i) = Fil.DateLastModified
X(5, i) = Fil.DateCreated
X(6, i) = Fil.Type
X(7, i) = Fil.Size
X(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
X(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
X(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
X(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)
Next
Call RecursiveFolder(oFolder)

ReDim Preserve X(11, i)
MainExtractData = Application.Transpose(X)

Set FSO = Nothing
Set objShell = Nothing
Set oFolder = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set Fil = Nothing
Application.StatusBar = ""
Application.ScreenUpdating = True
End Function

Sub RecursiveFolder(xFolder)
Dim SubFld
For Each SubFld In xFolder.SubFolders
Set oFolder = FSO.GetFolder(SubFld)
Set objFolder = objShell.Namespace(SubFld.Path)
For Each Fil In SubFld.Files
Set objFolder = objShell.Namespace(oFolder.Path)
'Problem with objFolder at times
If Not objFolder Is Nothing Then
Set objFolderItem = objFolder.ParseName(Fil.Name)
i = i + 1

X(1, i) = oFolder.Path
X(2, i) = Fil.Name
X(3, i) = Fil.DateLastAccessed
X(4, i) = Fil.DateLastModified
X(5, i) = Fil.DateCreated
X(6, i) = Fil.Type
X(7, i) = Fil.Size
X(8, i) = objFolder.GetDetailsOf(objFolderItem, 8)
X(9, i) = objFolder.GetDetailsOf(objFolderItem, 9)
X(10, i) = objFolder.GetDetailsOf(objFolderItem, 10)
X(11, i) = objFolder.GetDetailsOf(objFolderItem, 14)

Else
Debug.Print Fil.Path & " " & Fil.Name
End If
Next
Call RecursiveFolder(SubFld)
Next
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

[trpkob]

Thank you mdmackillop, where would the destination path be inputted here?

[trpkob]

Also, how is the date defined? 7 days prior to the current date?