Loop Through Sub Dir - vba

Question

I have the following code that requires me to manually update the "DateFolder" each time for my directories to move.
How do I update this so all the subfolders in the "source folder" are moved based on my code?
The folder structure is:
Date 1
|
Folder 1
|
Files
Date 2
|
Folder 1
|
Files
Sub MoveFolder()
'move any directories with all their contents listed in DIR_UPDATE
' from the source folder to the destination folder
Dim objFSO As Object
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim sourceFolder As String
Dim destinationFolder As String
Dim mysql As String
Dim DateFolder As String
DateFolder = "20160331"
mysql = "SELECT * from Update"
sourceFolder = "C:\Test\" & DateFolder & "\"
destinationFolder = "C:\Test\New\" & DateFolder & "\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set db = CurrentDb
Set rs = db.OpenRecordSet(mysql)
'look for folders from UPDATE and move them from sourcefolder to destinationfolder
While Not rs.EOF
UPdateFolder = sourceFolder & rs!Update '
'must tell dir that sourceFolder is a directory
If Dir(UPdateFolder, vbDirectory) <> "" Then
objFSO.MoveFolder Source:=UPdateFolder, destination:=destinationFolder '
Debug.Print "Move Folder Command Complete From: " & UPdateFolder & _
"......To: " & destinationFolder & rs!Update
Else
End If
rs.MoveNext
Wend
Debug.Print "Move Complete " & Now()
End Sub

Answer 1

How do you think about this code? I checked it in my OS.
Sub MoveFolder()
'
' move any directories with all their contents listed in DIR_UPDATE from the source folder to the Destination folder
'
Dim objFSO As Object
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim sourceFolder As String
Dim destinationFolder As String
Dim mysql As String
Dim DateFolder As String
Dim objFolder, objSubFolders
Dim UPdateFolder As String
Dim sourceFolder0 As String, destinationFolder0 As String
mysql = "SELECT * from [Update]"
Set db = CurrentDb
Set rs = db.OpenRecordset(mysql)
sourceFolder0 = "C:\Test"
destinationFolder0 = "C:\Test\New"
' sourceFolder = "C:\Test\" & DateFolder & "\"
' destinationFolder = "C:\Test\New\" & DateFolder & "\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sourceFolder0)
Set objSubFolders = objFolder.SubFolders
'
' loop over SubFolders to check them if they are DateFolder:
'
For Each objFolder In objSubFolders
'
' get SubFolder short name:
'
' DateFolder = "20160331"
'
DateFolder = objFolder.Name
'
' if it's a DateFolder in yyyymmdd format,
' eg 20160331, dir length = 8:
'
If (IsNumeric(DateFolder) And Len(DateFolder) = 8) Then
'
' sourceFolder = "C:\Test\" & DateFolder & "\"
' destinationFolder = "C:\Test\New\" & DateFolder & "\"
'
sourceFolder = sourceFolder0 & "\" & DateFolder & "\"
destinationFolder = destinationFolder0 & "\" & DateFolder & "\"
'
' check if the destination exists:
' create it if nonexistent.
'
If (Not objFSO.FolderExists(destinationFolder)) Then
objFSO.CreateFolder destinationFolder
End If
'
' look for folders from UPDATE and move them
' from sourcefolder to destinationFolder
'
While Not rs.EOF
UPdateFolder = sourceFolder & rs!Update
'
' must tell dir that sourceFolder is a directory:
'
If Dir(UPdateFolder, vbDirectory) <> "" Then
objFSO.MoveFolder Source:=UPdateFolder, Destination:=destinationFolder
Debug.Print "Move Folder Command Complete From: " _
& UPdateFolder & "......To: " _
& destinationFolder & rs!Update
Else
End If
rs.MoveNext
Wend
'
' rewind recordset for the next DateFolder:
'
rs.MoveFirst
'
End If
Next
rs.Close
Set rs = Nothing
Set objFolder = Nothing
Set objSubFolders = Nothing
Debug.Print "Move Complete " & Now()
End Sub