VBA to create sub folder when it does not exist

[gusbus]

So I have adapted this VBA code for my purposes but need help making an additional change. When the sub folder does not exist I need to have the program create the sub folder and run the file moving portion again.

Thanks in advance.

Sub MyMoveFiles()


    Dim myDestDir As String
    Dim myFileExt As String
    Dim i As Long
    Dim myFilePrefix As String
    Dim myFile
    Dim mySrc As String
    Dim mySubDest As String
    Dim myDest As String
    Dim DelFile As Boolean


'   Set up an array for all the different directories you wish to copy files from
'   Number in parentheses of variable declaration should be number of items in array - 1
    Dim mySourceDir(1)
    mySourceDir(0) = "C:\Users\Documents\FilesToBeMoved0\"
    mySourceDir(1) = "C:\Users\Documents\FilesToBeMoved1\"
    
'   Set source directory where subfolders are found
    myDestDir = "C:\Users\Documents\EntityFilings\"
    
'   Designate file extensions to move
    myFileExt = "*.*"
    
    
'   ***********************************************************************************
    
'   Loop through all each directory
    For i = LBound(mySourceDir) To UBound(mySourceDir)
'       Loop through each Excel file in each directory
        myFile = Dir(mySourceDir(i) & myFileExt)
        Do While Len(myFile) > 0
'           Get file prefix
            myFilePrefix = Left(myFile, 4)
'           Build source and destination references
            mySrc = mySourceDir(i) & myFile
'           Specify the sub folder
            mySubDest = Sheet4.Range("B4").Value
            myDest = myDestDir & myFilePrefix & "\" & mySubDest & "\" & myFile
'           Set boolean value to delete file
            DelFile = True
'           Copy file from source to destination
            On Error GoTo No_Folder
            FileCopy mySrc, myDest
            On Error GoTo 0
'           Delete source file, if flag is true
            If DelFile = True Then Kill mySrc
'           Reinitialize myFile
            myFile = Dir
        Loop
    Next i
    
    MsgBox "Moves complete!"
    
    Exit Sub
    
No_Folder:
'   If cannot find direcory for a file, do not delete, return message box, and continue
    If Err.Number = 76 Then
        DelFile = False
        MsgBox "Folder " & myDestDir & myFilePrefix & "\" & mySubDest & " does not exist.", vbOKOnly, _
               "Cannot move file " & mySrc & "!!!"
        Err.Clear
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If

End Sub

 

[ranman256]

just run MakeDir() every time.
if its not there, it makes it,
if it is there, no harm done, it moves on.

Public Sub MakeDir(ByVal pvDir)
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(pvDir) Then fso.CreateFolder pvDir     'MkDir pvDir
Set fso = Nothing
Exit Sub
errMake:
'MsgBox Err.Description & vbCrLf & pvDir, , "MakeDir(): " & Err
Set fso = Nothing
End Sub