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

DeMoNloK

New Member
Joined
Apr 17, 2021
Messages
29
Office Version
  1. 365
Platform
  1. Windows
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.
service.PNG



VBA Code:
[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]
 
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 …​
 
Upvote 0

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.
With some 'debug comments' in the VBE Immediate window :​
VBA Code:
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
 
Upvote 0
With some 'debug comments' in the VBE Immediate window :​
VBA Code:
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
 
Upvote 0
Read again post #11 …​
If nothing obviously obvious so try post #12 procedure then revert the 'debug comments' from the VBE Immediate window …​
 
Upvote 0
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
 
Upvote 0
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 ?​
 
Upvote 0
VBA Code:
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
 
Upvote 0
VBA Code:
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.

name with sub order.PNG


VBA Code:
[/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]
 
Upvote 0
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.

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,515
Messages
6,114,080
Members
448,548
Latest member
harryls

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top