Create new folder with current date and move specif files to it

[SantanaKRE8s]

Can someone please help with this VBA, I want to create a new folder with the current date and then move specific files to the new folder.

Sub FSOMoveAllFiles()
Dim FSO As New FileSystemObject
Dim FromPath As String
Dim ToPath As String
Dim FileInFromFolder As Object

FromPath = "H:\Desktop"
MkDir "G:\Branches\VS-SpaceX\Benjamin\FABRINET_THF002\CANCELED POs\FBN CXL REQ" & " " & Format(Now(), "M-DD-YYYY") & ""
ToPath = "G:\Branches\VS-SpaceX\Benjamin\FABRINET_THF002\CANCELED POs\FBN CXL REQ" & " " & Format(Now(), "M-DD-YYYY") & ""

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each FileInFromFolder In FSO.GetFolder(FromPath).Files
FileInFromFolder.Move ToPath
Next FileInFromFolder

End Sub

 

[SantanaKRE8s]

Hmm. Probably a bad idea then to name your Subroutine "FSOMoveAllFiles", don't you think?
Try this

Sub FSOMoveAllFiles()
    Dim FSO As New FileSystemObject                   'early binding of FSO oject
    Dim FromPath As String, ToPath As String, FileInFromFolder As File, DateStr As String, FldrName As String, BasePath As String
    Dim MCnt As Long
   
    DateStr = Format(Now(), "M-DD-YYYY")
    FldrName = "FBN CXL REQ" & DateStr
    BasePath = "G:\Branches\VS-SpaceX\Benjamin\FABRINET_THF002\CANCELED POs\"
    FromPath = "H:\Desktop"
   
    If Not FSO.FolderExists(FromPath) Then
        Debug.Print "Folder '" & FromPath & "' does not exist"
        MsgBox "Folder '" & FromPath & "' does not exist", vbCritical
        Exit Sub
    End If
   
    If Not FSO.FolderExists(BasePath) Then
        Debug.Print "Folder '" & BasePath & "' does not exist"
        MsgBox "Folder '" & BasePath & "' does not exist", vbCritical
        Exit Sub
    End If
   
    ToPath = BasePath & FldrName
   
    If Not FSO.FolderExists(ToPath) Then
        FSO.CreateFolder ToPath
    End If
   
    If Not FSO.FolderExists(ToPath) Then
        Debug.Print "Folder '" & ToPath & "' does not exist"    'optional
        MsgBox "Folder '" & ToPath & "' does not exist" & vbCr & vbCr & "Folder creation unsuccessful", vbCritical    'optional
        Exit Sub
    End If
   
    With FSO.GetFolder(FromPath)
        For Each FileInFromFolder In .Files
            Debug.Print FileInFromFolder.Name
            Select Case Trim(Left(FileInFromFolder.Name, 12))
                Case "CANCEL.xlsx", "THF002.xlsx", "FBN CXL REQ"
                    FileInFromFolder.Move ToPath
                    MCnt = MCnt + 1
            End Select
        Next FileInFromFolder
    End With
   
    MsgBox MCnt & " files moved.", vbInformation
End Sub

Its stops here on the second time around. So it creates the new folder with name and current date, it goes to through all the way to "Next FileInFromFolder" and then goes back to "Debug.Print FileInFromFolder.Name" and then down to "FileInFromFolder.Move ToPath" and this is where it stops. Run time error '58' File already exist.

 

[rlv01]

Its stops here on the second time around

That is unsurprising. You chose to use the statement FileInFromFolder.Move ToPath in your original code. The file object .move method works only when the target file does not exist. It can't overwrite and will produce an error if the file already exists. If you want it to behave differently then changes will be needed.

 

[SantanaKRE8s]

That is unsurprising. You chose to use the statement FileInFromFolder.Move ToPath in your original code. The file object .move method works only when the target file does not exist. It can't overwrite and will produce an error if the file already exists. If you want it to behave differently then changes will be needed.

I dont mind making changes necessary to make this work.
This is my process -

I have a code in another module that gets data from these two workbooks CANCEL.XLSX and THF002.XLSX to create the FBN CXL REQ (With Current Date).XLSX
and a module to reset the master file.
and I want a code to move all files used into a folder with the name "FBN CXL REQ and current date ", This is the one I am having trouble with. Creating the folder and moving the files. Don mind making changes to make it work. thank you for your help and patience.

 

[rlv01]

Try using

FileInFromFolder.Copy ToPath, True

instead of

FileInFromFolder.Move ToPath

 

[SantanaKRE8s]

Try using

FileInFromFolder.Copy ToPath, True

instead of

FileInFromFolder.Move ToPath

Made the change, but now there is a permision denied.

 

[rlv01]

Try this instead.

    With FSO.GetFolder(FromPath)
        For Each FileInFromFolder In .Files
            Select Case Trim(Left(FileInFromFolder.Name, 12))
                Case "CANCEL.xlsx", "THF002.xlsx", "FBN CXL REQ"
                    If FSO.FileExists(ToPath) Then
                        Debug.Print FileInFromFolder.Name
                        Select Case MsgBox("File '" & FileInFromFolder.Name & "' already exists in the destination folder. " & vbCrLf & vbCrLf _
                                & "Do you want to overwrite it?", vbYesNoCancel Or vbQuestion, Application.Name)
                            Case vbYes
                                Kill ToPath
                                FileInFromFolder.Move ToPath
                                MCnt = MCnt + 1
                            Case vbCancel
                                Exit Sub
                        End Select
                    Else
                        FileInFromFolder.Move ToPath
                        MCnt = MCnt + 1
                    End If
            End Select
        Next FileInFromFolder
    End With

 

[SantanaKRE8s]

Try this instead.

    With FSO.GetFolder(FromPath)
        For Each FileInFromFolder In .Files
            Select Case Trim(Left(FileInFromFolder.Name, 12))
                Case "CANCEL.xlsx", "THF002.xlsx", "FBN CXL REQ"
                    If FSO.FileExists(ToPath) Then
                        Debug.Print FileInFromFolder.Name
                        Select Case MsgBox("File '" & FileInFromFolder.Name & "' already exists in the destination folder. " & vbCrLf & vbCrLf _
                                & "Do you want to overwrite it?", vbYesNoCancel Or vbQuestion, Application.Name)
                            Case vbYes
                                Kill ToPath
                                FileInFromFolder.Move ToPath
                                MCnt = MCnt + 1
                            Case vbCancel
                                Exit Sub
                        End Select
                    Else
                        FileInFromFolder.Move ToPath
                        MCnt = MCnt + 1
                    End If
            End Select
        Next FileInFromFolder
    End With

Made the changes and im getting " Run-time error '58': File already exist.

 

[rlv01]

Sorry, that was my typo.

 If FSO.FileExists(ToPath) Then

should be

If FSO.FileExists(ToPath & "\" & FileInFromFolder.Name) Then

 

[SantanaKRE8s]

Sorry, that was my typo.

 If FSO.FileExists(ToPath) Then

should be

If FSO.FileExists(ToPath & "\" & FileInFromFolder.Name) Then

For some reason it keeps stopping at the same place " FileInFromFolder.Move ToPath "


Sub FSOMoveAllFiles()
Dim FSO As New FileSystemObject 'early binding of FSO oject
Dim FromPath As String, ToPath As String, FileInFromFolder As File, DateStr As String, FldrName As String, BasePath As String
Dim MCnt As Long

DateStr = Format(Now(), "M-DD-YYYY")
FldrName = "FBN CXL REQ " & DateStr
BasePath = "G:\Branches\VS-SpaceX\Benjamin\FABRINET_THF002\CANCELED POs\"
FromPath = "H:\Desktop"

If Not FSO.FolderExists(FromPath) Then
Debug.Print "Folder '" & FromPath & "' does not exist"
MsgBox "Folder '" & FromPath & "' does not exist", vbCritical
Exit Sub
End If

If Not FSO.FolderExists(BasePath) Then
Debug.Print "Folder '" & BasePath & "' does not exist"
MsgBox "Folder '" & BasePath & "' does not exist", vbCritical
Exit Sub
End If

ToPath = BasePath & FldrName

If Not FSO.FolderExists(ToPath) Then
FSO.CreateFolder ToPath
End If

If Not FSO.FolderExists(ToPath) Then
Debug.Print "Folder '" & ToPath & "' does not exist" 'optional
MsgBox "Folder '" & ToPath & "' does not exist" & vbCr & vbCr & "Folder creation unsuccessful", vbCritical 'optional
Exit Sub
End If

With FSO.GetFolder(FromPath)
For Each FileInFromFolder In .Files
Select Case Trim(Left(FileInFromFolder.Name, 12))
Case "CANCEL.xlsx", "THF002.xlsx", "FBN CXL REQ"
If FSO.FileExists(ToPath & "\" & FileInFromFolder.Name) Then
Debug.Print FileInFromFolder.Name
Select Case MsgBox("File '" & FileInFromFolder.Name & "' already exists in the destination folder. " & vbCrLf & vbCrLf _
& "Do you want to overwrite it?", vbYesNoCancel Or vbQuestion, Application.Name)
Case vbYes
Kill ToPath
FileInFromFolder.Move ToPath
MCnt = MCnt + 1
Case vbCancel
Exit Sub
End Select
Else
FileInFromFolder.Move ToPath
MCnt = MCnt + 1
End If
End Select
Next FileInFromFolder
End With

MsgBox MCnt & " files moved.", vbInformation
End Sub

 

[rlv01]

Can you post your entire code with all modifications for Sub FSOMoveAllFiles() ?

When you do, please try to use code tags like I did above when posting code. It makes your code easier to read and copy.

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com