Copy and Move files to existing Sub-folders based on filename/Sub-folders's Name

[JOEYSCLEE]

Hi, there
Would you please to advise VBA code for copying and moving files to existing Sub-folders based on Filename/Sub-folders's Name? The date of Filenames will be changed daily. Meanwhile, it's better to have path selection for selecting the source folder to copy those files and paste them to destination folder.

[mana]

Option Explicit


Sub test()
    Dim pFld As String, cFld As String, myFile As String
       
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            pFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    myFile = Dir(pFld & "*.*")
  
    Do While myFile <> ""
        cFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
        Name pFld & myFile As pFld & cFld & "\" & myFile
        myFile = Dir()
    Loop
    
End Sub

[JOEYSCLEE]

Thanks Mana!! It works great! Nevertheless, those files are located in another other drive (not same as Folder location). Could you please help to advise the code again?

[JOEYSCLEE]

Thanks Mana!! It works great! Nevertheless, those files are located in another other drive (not same as Folder location). Could you please help to advise the code again?

[mana]

Option Explicit
  
Sub test2()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    myFile = Dir(srcFld & "*.*")
     
    Do While myFile <> ""
        subFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
        Name srcFld & myFile As dstFld & subFld & "\" & myFile
        myFile = Dir()
    Loop
     
End Sub

[JOEYSCLEE]

Thanks Mana!! Nevertheless, It has error message after running new code.

Option Explicit
  
Sub test2()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    myFile = Dir(srcFld & "*.*")
     
    Do While myFile <> ""
        subFld = Mid(myFile, 1, InStrRev(myFile, " ") - 1)
        Name srcFld & myFile As dstFld & subFld & "\" & myFile
        myFile = Dir()
    Loop
     
End Sub

[mana]

vOption Explicit 

Sub test3()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
    Dim n As Long
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    myFile = Dir(srcFld & "*.*")
  
    Do While myFile <> ""
        n = InStrRev(myFile, " ") - 1
        If n > 0 Then
            subFld = Mid(myFile, 1, n)
            Name srcFld & myFile As dstFld & subFld & "\" & myFile
        End If
        myFile = Dir()
    Loop
     
End Sub

[JOEYSCLEE]

Run Time Error "53" after running the revised code.

vOption Explicit 

Sub test3()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
    Dim n As Long
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1) & "\"
        Else
            Exit Sub
        End If
    End With
     
    myFile = Dir(srcFld & "*.*")
  
    Do While myFile <> ""
        n = InStrRev(myFile, " ") - 1
        If n > 0 Then
            subFld = Mid(myFile, 1, n)
            Name srcFld & myFile As dstFld & subFld & "\" & myFile
        End If
        myFile = Dir()
    Loop
     
End Sub

[mana]

rule of flename


Sub-folders's Name & space & date & ,extension

Option Explicit
 
Sub test4()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
    Dim fso As Object, f As Object
    Dim n As Long
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each f In fso.GetFolder(srcFld).Files
        myFile = f.Name
        n = InStrRev(myFile, " ") - 1
        If n > 1 Then
            subFld = dstFld & "\" & Mid(myFile, 1, n)
            If fso.FolderExists(subFld) Then
                f.Move subFld & "\"
            End If
        End If
    Next
     
End Sub

[JOEYSCLEE]

Below code works great. Thank you very much!!

rule of flename


Sub-folders's Name & space & date & ,extension

Option Explicit
 
Sub test4()
    Dim srcFld As String, dstFld As String, subFld As String, myFile As String
    Dim fso As Object, f As Object
    Dim n As Long
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\*****\*****"
        .Title = "select source folder"
        If .Show Then
            srcFld = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "D:"
        .Title = "select destination folder"
        If .Show Then
            dstFld = .SelectedItems.Item(1)
        Else
            Exit Sub
        End If
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each f In fso.GetFolder(srcFld).Files
        myFile = f.Name
        n = InStrRev(myFile, " ") - 1
        If n > 1 Then
            subFld = dstFld & "\" & Mid(myFile, 1, n)
            If fso.FolderExists(subFld) Then
                f.Move subFld & "\"
            End If
        End If
    Next
     
End Sub