Move files based on file name

[gilligan5000]

Hi guys, I usually just search like crazy and can find a solution on here that's close enough that I can make it work...not this time.

I have three source folders with 1,000's of files in each.
Each file in these folders starts with a 6 digit number.
I would like to take each file, read the 6 digit number from it, and copy the file to a new folder that also starts with that number (already created).

In essence a bulk file move that searches source file names, and destination folder names and aligns the two...

Any VBA experts out there I would greatly appreciate the help! I really don't feel like moving these manually



Source Path Layout:

\SAP\Preventive Maintenance\ (folder has 1,000 files starting with a 6 digit number)
\SAP\Calibration\ (folder has 1,000 files starting with a 6 digit number)
\SAP\Impact Assessments\ (folder has 1,000 files starting with a 6 digit number)


I would like to combine all of these into corresponding folders here:

\SAP\Equipment Files\ (1,000 folders, one for each number)

 

[Joe4]

Welcome to the Board!

I created an example on my system, and created the code for it. You should be able to adapt this code to work for you. You will just need to edit the variables above the stars to reflect your environment:

Sub MyMoveFiles()


    Dim myDestDir As String
    Dim myFileExt As String
    Dim i As Long
    Dim myFilePrefix As String
    Dim myFile
    Dim mySrc As String
    Dim myDest As String
    Dim DelFile As Boolean


'   Set up an array for all the different directories you wish to copy files from
'   Number in parentheses of variable declaration should be number of items in array - 1
    Dim mySourceDir(1)
    mySourceDir(0) = "C:\temp\"
    mySourceDir(1) = "C:\testfiles\"
    
'   Set source directory where subfolders are found
    myDestDir = "C:\C\"
    
'   Designate file extensions to move
    myFileExt = "*.xl*"
    
'   ***********************************************************************************
    
'   Loop through all each directory
    For i = LBound(mySourceDir) To UBound(mySourceDir)
'       Loop through each Excel file in each directory
        myFile = Dir(mySourceDir(i) & myFileExt)
        Do While Len(myFile) > 0
'           Get file prefix
            myFilePrefix = Left(myFile, 6)
'           Build source and destination references
            mySrc = mySourceDir(i) & myFile
            myDest = myDestDir & myFilePrefix & "\" & myFile
'           Set boolean value to delete file
            DelFile = True
'           Copy file from source to destination
            On Error GoTo No_Folder
            FileCopy mySrc, myDest
            On Error GoTo 0
'           Delete source file, if flag is true
            If DelFile = True Then Kill mySrc
'           Reinitialize myFile
            myFile = Dir
        Loop
    Next i
    
    MsgBox "Moves complete!"
    
    Exit Sub
    
No_Folder:
'   If cannot find direcory for a file, do not delete, return message box, and continue
    If Err.Number = 76 Then
        DelFile = False
        MsgBox "Folder " & myDestDir & myFilePrefix & " does not exist.", vbOKOnly, _
               "Cannot move file " & mySrc & "!!!"
        Err.Clear
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If


End Sub

 

[gilligan5000]

Joe4 - Thanks for the quick reply!

First - thank you for the detailed comments! that really helps follow along nicely.

Its been running for 5 minutes and the results look awesome so far!!!! I can't thank you enough. Thanks again for not only answering this, but making it so that I UNDERSTAND the code!

 

[Joe4]

Your welcome!
Glad it seems to be working for you.