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]

 

[Marc L]

​

So just investigate the process in step by step mode - hitting F8 key - to check the variables contents in the VBE Locals window …​

​

And according to VBA help of Name statement - kid level reading - the file must not already exists in the destination folder …​

 

[Marc L]

With some 'debug comments' in the VBE Immediate window :​

Sub Demo1d()
    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"
      Dim F$, L&, S$(), P$
          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
            P = TD & Split(S(L))(0) & "\Service Reports\"
        If Dir(P, vbDirectory) = "." Then
            If Dir(P & S(L)) = "" Then Name FD & S(L) As P & S(L) Else Debug.Print "File "; P & S(L); " already exists !"
        Else
            Debug.Print S(L); " : folder "; P; " does not exist !"
        End If
    Next
End Sub

 

[DeMoNloK]

With some 'debug comments' in the VBE Immediate window :​

Sub Demo1d()
    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"
      Dim F$, L&, S$(), P$
          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
            P = TD & Split(S(L))(0) & "\Service Reports\"
        If Dir(P, vbDirectory) = "." Then
            If Dir(P & S(L)) = "" Then Name FD & S(L) As P & S(L) Else Debug.Print "File "; P & S(L); " already exists !"
        Else
            Debug.Print S(L); " : folder "; P; " does not exist !"
        End If
    Next
End Sub

This has me feeling pretty beat-up, so close but I just don't understand what's going on. If you can solve this I'll paypal you $50.00

 

[DeMoNloK]

This has me feeling pretty beat-up, so close but I just don't understand what's going on. If you can solve this I'll paypal you $50.00

Try to move the file to folder 1234567.pdf to "folder 1234567 project" with the sub-folder service report

 

[Marc L]

​

Read again post #11 …​

​

If nothing obviously obvious so try post #12 procedure then revert the 'debug comments' from the VBE Immediate window …​

 

[DeMoNloK]

​

Read again post #11 …​

​

If nothing obviously obvious so try post #12 procedure then revert the 'debug comments' from the VBE Immediate window …​

Been running through the debugger, I am noticing that once it finds all the files it goes directly to the des folder only using the 7 digits "C:\Users\RyZeNx\Desktop\wip\2111263 " it's like there needs to one more step in scanning all folders by name to see if there is a match. The reason it's not working is when the the folder is renamed passed just the 2111263 the vba doesn't recognize the folder

 

[Marc L]

​

I skipped the renamed folder part … But to be sure write a sample of an initial source file name and its complete destination …​

​

As the final folder does not exactly match the source file name beginning I hope there is only a single final folder starting with the same name ?​

 

[Marc L]

Sub Demo1r2d2()
    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"
      Dim F$, L&, S$(), 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
           P = Dir(TD & Split(S(L))(0) & "*", vbDirectory)
        If P = "" Then
            Debug.Print S(L); " : folder does not exist !"
        Else
                P = TD & P & "\Service Reports\"
            If Dir(P, vbDirectory) = "." Then
                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

 

[DeMoNloK]

Sub Demo1r2d2()
    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"
      Dim F$, L&, S$(), 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
           P = Dir(TD & Split(S(L))(0) & "*", vbDirectory)
        If P = "" Then
            Debug.Print S(L); " : folder does not exist !"
        Else
                P = TD & P & "\Service Reports\"
            If Dir(P, vbDirectory) = "." Then
                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

ECELLENT work! Love the names in here it's awesome!
My first attempt with the new raw code ghosted the pdf's, I added Left(fName, 7) in line #12 it is now moving the files into folders using the first 7 naming scheme.
I added new folders within the project subfolder to simulate basic folder structure. As long as there is a service report folder in the project folder the files will be moved.
So now what's next? I have pdf files that are named passed the 7 digit standard, the naming scheme is the same name but with some projects requiring a sub-order number to be included into the name.
Standard name example; "1234567 Date name code.pdf" Sub-order name example; "1234567001 Date name code.pdf" the sub order number is used for tracking mini projects within the main project.
So my next goal is to find the files by name and using only the first 7 digits and moving them even if the first name has 10 digits.
The picture below showing the vba working as long as the names of the files and folders are identical.

[/COLOR]
Sub Demo1r2d2()

    Const FD = "C:\Users\RyZeNx\Desktop\test\", TD = "C:\Users\RyZeNx\Desktop\wip\"

      Dim F$, L&, S$(), 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

           P = Dir(TD & Split(S(L))(0) & "*", vbDirectory)

        If P = "" Then

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

        Else

                P = TD & P & Left(fName, 7) & "\Service Reports\"

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

                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
[COLOR=#000000]

 

[Marc L]

So my next goal is to find the files by name and using only the first 7 digits and moving them even if the first name has 10 digits.

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