Renaming all files with part of subfolder name using VBA

Question

I have a main folder, with many subfolders, and many files within those subfolders. I would like to add the suffix of the subfolder to the prefix of every file within the subfolder. I would then like to export all files within all subfolders, with the new prefix, to a new general folder to be bulk uploaded into a platform.

Before: C:\DESKTOP\EMPLOYEES\ is main folder, within this main folder there are many subfolders C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345, within these subfolders I have many files C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345\contract.pdf C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345\confidentialityagreement.pdf ...

After: C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345
C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345\12345_contract.pdf C:\DESKTOP\EMPLOYEES\JOHN_DOE_12345\12345_confidentialityagreement.pdf

The number of characters will always vary for the subfolder names, but I figured I could somehow look specifically for the number after the second "_" to add as prefix.

I have VBA below that has been working great to at least rename the files with the folder name, but now I need to alter to only grab the number after the second "_" and also then move the files into a general folder.

Any help would be appreciated!

Below macro is used in Excel where in cell A7 I have the main folder path.

Sub doIt()
' Add reference: Tools->References->Microsoft Scripting Runtime
Dim fso As FileSystemObject
Dim fldMain As Folder
Dim fld As Folder
Dim fil As File
Dim file_path As String

    Set fso = New FileSystemObject
   
    ' Main folder that contains the subfolders
    Set fldMain = fso.GetFolder(Range("A7").Value)
   
    ' Loop through subfolders
    For Each fld In fldMain.SubFolders
            ' Loop through files in the subfolder
            For Each fil In fld.Files
                With fil
                    ' Rename the file in the subfolder
                    .Move fld.Path & Application.PathSeparator & fld.Name & "_" & .Name

                End With
            Next fil
    Next fld
End Sub

Answer 1

Copy Files

• This will not modify the source files.
• It will copy them renamed to the destination folder.
• Make sure that the code works correctly before you replace .Copy with .Move to move them.
• Adjust the worksheet name Sheet1 and the cell holding the destination path A8.

Sub CopyFiles()
    ' Add reference: Tools->References->Microsoft Scripting Runtime
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' ADJUST!
    
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
   
    ' Get the source folder (object).
    Dim sFolderPath As String: sFolderPath = CStr(ws.Range("A7").Value)
    If Not fso.FolderExists(sFolderPath) Then
        MsgBox "The source folder """ & sFolderPath & """ doesn't exist.", _
            vbCritical
        Exit Sub
    End If
    Dim sFolder As Folder: Set sFolder = fso.GetFolder(sFolderPath)
    
    ' Get the destination folder path (string).
    Dim dFolderPath As String: dFolderPath = CStr(ws.Range("A8").Value) ' ADJUST!
    If Not fso.FolderExists(dFolderPath) Then
        MsgBox "The destination folder """ & dFolderPath & """ doesn't exist.", _
            vbCritical
        Exit Sub
    End If
    
    Dim sSubfolder As Folder
    Dim sFile As File
    Dim sDelimiterPosition As Long
    Dim ssName As String
    Dim dPrefix As String
    Dim dPath As String
    
    ' Do it.
    For Each sSubfolder In sFolder.SubFolders
        ssName = sSubfolder.Name
        sDelimiterPosition = InStrRev(ssName, "_")
        If sDelimiterPosition > 0 Then ' subfolder has delimiter
            dPrefix = Right(ssName, Len(ssName) - sDelimiterPosition)
            For Each sFile In sSubfolder.Files
                dPath = fso.BuildPath(dFolderPath, dPrefix & "_" & sFile.Name)
                sFile.Copy Destination:=dPath ', OverWriteFiles:=True ' default
            Next sFile
        'Else ' subfolder doesn't have delimiter; do nothing
        End If
    Next sSubfolder

End Sub