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
12
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]
 

DeMoNloK

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

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

Marc L

Active Member
Joined
Apr 5, 2021
Messages
414
Office Version
  1. 2010
Platform
  1. Windows
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 …​
 

Watch MrExcel Video

Forum statistics

Threads
1,129,285
Messages
5,635,312
Members
416,852
Latest member
kanaikls

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
Top