Macro move file to existing folder by name using filename first left7 digits with a space delimiter

[DeMoNloK]

I'm looking for some help. I started trying to use excel for this project yesterday.
I originally scripted a batch file to run this operation.
The batch works in a small and limited environment.
I tried the batch in a live folder and it was a complete failure with files being multiplied and moved into random folders.

My goal is to move 50+ new .pdf files created everyday using the first 7 digits and an accompanying space to match my Projects folder working structure.
all .pdf will start with a 7 digit number followed by a space between each date and name, the folder structure is set up using the 7 digit naming but has info about the project.
file example; 1234567 4-17-2021 name hr code.pdf Folder example; 1234567 projectName Date with a subfolder of service reports, the service report folder within the main project folder will house all incoming .pdfs'
The code below works, but will only work when the folder has only 7 digits. As soon as I rename the folder to match the naming scheme of the actual folder layout excel freezes and then crashes.
Any and all help will be appreciated.

[COLOR=rgb(41, 105, 176)]Sub MoveFiles()




Dim fName As String, fromPath As String, toPath As String, Cnt As Long
On Error Resume Next



toPath = "C:\Users\RyZeNx\Desktop\wip\"
fromPath = "C:\Users\RyZeNx\Desktop\test\"

Restart:
If Cnt > 1 Then Exit Sub
fName = Dir(fromPath & "*.pdf")

Do While Len(fName) > 4
    If Cnt > 1 Then Exit Sub
    Cnt = 0
    toSubPath = toPath & Left(fName, 7) & "\Service Reports\"
    If Len(Dir(toSubPath, vbDirectory)) = 0 Then MkDir toSubPath
    Name (fromPath & fName) As (toSubPath & fName)
    fName = Dir
Loop

Cnt = Cnt + 1
GoTo Restart



End Sub[/COLOR]

 

[DeMoNloK]

Sub Demo2()
    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"
      Dim F$, L&, S$(), T$, P$, BILL$
          F = Dir(FD & "*.pdf")
    While F > ""
        L = L + 1
        ReDim Preserve S(1 To L)
        S(L) = F
        F = Dir
    Wend
    For L = 1 To L
           T = Left(S(L), 7)
           P = Dir(TD & T & "*", vbDirectory)
        If P = "" Then
            Debug.Print S(L); " : folder does not exist !"
        Else
                P = TD & P & "\Service Reports\"
            If Dir(P, vbDirectory) = "." Then
                If InStr(S(L), " ") > 8 Then BILL = P & T & " " & Mid(S(L), 8) Else BILL = P & S(L)
                If Dir(BILL) > "" Then Kill BILL
                Name FD & S(L) As BILL
            Else
                Debug.Print S(L); " : folder "; P; " does not exist !"
            End If
        End If
    Next
End Sub

Your a Genius!!! I was on the right track, I knew we would have to split after creating the array before it points to the folder. Very good work! DM me you email and I'll follow thru with my offer.

 

[Marc L]

​

As you already have 'payed' me with your likes, thanks, I appreciate !​

​

As this is a forum to help gently, not to make money but you can give some bucks to an association …​

 

[DeMoNloK]

​

As you already have 'payed' me with your likes, thanks, I appreciate !​

​

As this is a forum to help gently, not to make money but you can give some bucks to an association …​

Can we get this code to work to move the folders themselves to another folder, or do I need to write new code?

 

[Marc L]

​

As the Name statement moves also folders …​

 

[DeMoNloK]

​

As the Name statement moves also folders …​

I've been messing around with the code and have opened every search result, with no luck. The code below is finding the folders but saying the file already exists. I do notice that I'm getting a double backslash while debugging.

F = Dir(FD & "*", vbDirectory)
          

    While F > "*"

        L = L + 1

        ReDim Preserve S(1 To L)

Any thoughts?
I've also tried to set the file type as a .File folder

 

[DeMoNloK]

I've been messing around with the code and have opened every search result, with no luck. The code below is finding the folders but saying the file already exists. I do notice that I'm getting a double backslash while debugging.

F = Dir(FD & "*", vbDirectory)
         

    While F > "*"

        L = L + 1

        ReDim Preserve S(1 To L)

Any thoughts?
I've also tried to set the file type as a .File folder

I got it!!

Sub movefilewithsubs()

    Const FD = "C:\Users\RyZeNx\Desktop\wip\", TD = "C:\Users\RyZeNx\Desktop\jobs\"
    Set Fso = CreateObject("Scripting.FileSystemObject")
      Dim F$, L&, S$(), T$, P$, BILL$

          F = Dir(FD & "*", vbDirectory)
          

    While F > ""

        L = L + 1

        ReDim Preserve S(1 To L)

        S(L) = F

        F = Dir

    Wend

    For L = 1 To L

           T = Left(S(L), 5)

           P = Dir(TD & T & "*", vbDirectory)

        If P = "" Then

            Debug.Print S(L); " : folder does not exist !"

        Else

                P = TD & P & "\moved\"

            If Dir(P, vbDirectory) = "." Then

                If InStr(S(L), " ") > 8 Then BILL = P & T & " " & Mid(S(L), 8) Else BILL = P & S(L)

                If Dir(BILL) > "" Then Kill BILL

                Name FD & S(L) As BILL

            Else

                Debug.Print S(L); " : folder "; P; " does not exist !"

            End If

        End If

    Next

End Sub

 

[Marc L]

​

Well done !​

​

Why do you need FSO ? Seems useless in your VBA procedure …​

 

[DeMoNloK]

​

Well done !​

​

Why do you need FSO ? Seems useless in your VBA procedure …​

I was trying everything I could Lolz

 

[DeMoNloK]

​

Well done !​

​

Why do you need FSO ? Seems useless in your VBA procedure …​

Thanks to your help!!!!

 

[DeMoNloK]

Thanks to your help!!!!

@Marc L, how would I be able to use this if I want to move a file using the left 7 of the filename and moving into folder using the right 7 of the folder name?
I've split and trimmed but not having any luck getting the dir to read backwards. Any thoughts?