Hi VBA experts,
I need some help on a data archiving project.
Basically I am trying to move data that are 2 days old out from original folder into a backup folder and a network drive. The 2 day time window is needed so that when the macro auto runs by task scheduler, it will not affect any folders/files that are currently being created/written/read only.
Below is what i have come up with. Thus I need some help to input the code for the 2 days old folder check.
here is my chain of events
Data created (multiple folders with multiple files in each folder)-->check if folder is 2 days old --> move folder out to ready folder --> copy to network --> move to completed backup
(need help for this portion)
Sub Move_Ready_Files()
'this work to move ready files. still have to click cancel for inuse files.
Dim z As String
Dim strSource As String
Dim strDest As String
Dim i As Long
'Set Source and Destination Folder paths
strSource = "D:\Latest Results\": strDest = "D:\ReadyToBackup\" ' change to suit
'Put all Folders in Source folder into an array
z = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strSource & "*.*"" /s /b /o:n").StdOut.ReadAll, vbCrLf)
'Loop though the Array
For i = LBound(z) To UBound(z) - 1
'Move the files from each folder to the Destination Folder.. overwriting existing ones (16)..
CreateObject("shell.application").Namespace((strDest)).MoveHere (z(i)), 16
Next i
End Sub
Sub Perform_backup()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "D:\ReadyToBackup\" '<< Change
ToPath = "\\network\Raw Data\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
'-----------------------------------------------------------------------------------------------------------------------------------
FromPath = "D:\ReadyToBackup\" '<< Change
ToPath = "D:\Completed backup\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
End If
FSO.moveFolder Source:=FromPath, Destination:=ToPath
'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
' To recreate the original folder
MkDir "D:\ReadyToBackup\"
End Sub
I need some help on a data archiving project.
Basically I am trying to move data that are 2 days old out from original folder into a backup folder and a network drive. The 2 day time window is needed so that when the macro auto runs by task scheduler, it will not affect any folders/files that are currently being created/written/read only.
Below is what i have come up with. Thus I need some help to input the code for the 2 days old folder check.
here is my chain of events
Data created (multiple folders with multiple files in each folder)-->check if folder is 2 days old --> move folder out to ready folder --> copy to network --> move to completed backup
(need help for this portion)
Sub Move_Ready_Files()
'this work to move ready files. still have to click cancel for inuse files.
Dim z As String
Dim strSource As String
Dim strDest As String
Dim i As Long
'Set Source and Destination Folder paths
strSource = "D:\Latest Results\": strDest = "D:\ReadyToBackup\" ' change to suit
'Put all Folders in Source folder into an array
z = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & strSource & "*.*"" /s /b /o:n").StdOut.ReadAll, vbCrLf)
'Loop though the Array
For i = LBound(z) To UBound(z) - 1
'Move the files from each folder to the Destination Folder.. overwriting existing ones (16)..
CreateObject("shell.application").Namespace((strDest)).MoveHere (z(i)), 16
Next i
End Sub
Sub Perform_backup()
'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
FromPath = "D:\ReadyToBackup\" '<< Change
ToPath = "\\network\Raw Data\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
End If
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
'-----------------------------------------------------------------------------------------------------------------------------------
FromPath = "D:\ReadyToBackup\" '<< Change
ToPath = "D:\Completed backup\" & Format(Now, "yyyy-mm-dd h-mm-ss")
If Right(FromPath, 1) = "\" Then
FromPath = Left(FromPath, Len(FromPath) - 1)
End If
If Right(ToPath, 1) = "\" Then
ToPath = Left(ToPath, Len(ToPath) - 1)
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
End If
FSO.moveFolder Source:=FromPath, Destination:=ToPath
'MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath
' To recreate the original folder
MkDir "D:\ReadyToBackup\"
End Sub