Renaming Files in directory not only a folder

Question

I am working on a project in excel, where I am renaming multiple files.

Fow now I am using this code

Sub RenameFiles()  

Dim xDir As String  
Dim xFile As String  
Dim xRow As Long  
With Application.FileDialog(msoFileDialogFolderPicker)  
    .AllowMultiSelect = False  
If .Show = -1 Then  
    xDir = .SelectedItems(1)  
    xFile = Dir(xDir & Application.PathSeparator & "*")  
    Do Until xFile = ""  
        xRow = 0  
        On Error Resume Next  
        xRow = Application.Match(xFile, Range("A:A"), 0)  
        If xRow > 0 Then  
            Name xDir & Application.PathSeparator & xFile As _  
            xDir & Application.PathSeparator & Cells(xRow, "G").Value  
        End If  
        xFile = Dir  
    Loop  
End If  
End With    
End Sub    

which lets me change the names of the files in one specific folder, but I would like to be able to pick the main folder containing subfolders and it would change all the names corresponding with names I have made in my excel sheet.

Answer 1

I’m sure you are aware that renaming files if go wrong can have very serious, sometimes even catastrophic consequences, with that been said I hope that all necessary step to avoid any of those problems have been taken.

Data and Code:
It seems that columns A and G contain the "old" and "new" names of the files (excluding the path), and that’s the reason of asking the user for the path and the possibility of running the renaming of the files for subfolders as well.

The code posted compares every file in the folders (and subfolder as expected) against the list of files in the data, which could be time consuming.

Also, I’ll would suggest to have a track of what files have been renamed, so in case of any error, this allows to easily track back and undo what could have be an error.

Solution Proposed
The solution proposed below uses the FileSystemObject object which provides a robust access to the machine file system, you can interact with it in two manners: Early and Late Binding (Visual Basic). These procedures use late binding, to use early binding see How do I use FileSystemObject in VBA?

1. Folders_ƒGet_From_User: A function that ask the user to select the folder and to process or not subfolders. It returns a list of the subfolder selected (names only), excluding folders with no files.
2. Files_Get_Array: Creates and array with all the Filenames to be processed (Old & New)
3. Files_ƒRename: This function renames all files found in any of the folders from the list obtained from point 1. These procedure instead of validating every file present in the subfolders against the list, check if the files in the list Exist in any folder, and if so passes to the function File_ƒRename_Apply that does the renaming and returns the result, allowing the creation of the “Audit Track” array. It returns an array with the results of all the files names in the list in all the folders list ( from point 1 and 2) respectively.
4. File_Rename_Post_Records: Creates a worksheet named FileRename(Track) (if not present) to post the Audit Track of the results of the Files_ƒRename function.

All of them are called from the procedure: Files_Rename

Let me know of any questions you might have regarding the resources used.

Option Explicit

Private Const mk_Wsh As String = "FileRename(Track)"
Private Const mk_MsgTtl As String = "Files Rename"
Private mo_Fso As Object

…

Sub Files_Rename()
    Dim aFolders() As String, aFiles As Variant
    Dim aRenamed As Variant

    
    Set mo_Fso = CreateObject("Scripting.FileSystemObject")
    
    If Not (Folders_ƒGet_From_User(aFolders)) Then Exit Sub
                    
    Call Files_Get_Array(aFiles)
                    
    If Not (Files_ƒRename(aRenamed, aFolders, aFiles)) Then
        Call MsgBox("None file was renamed", vbInformation, mk_MsgTtl)
        Exit Sub
    End If
   
    Call File_Rename_Post_Records(aFiles, aRenamed)
    Call MsgBox("Files were renamed" & String(2, vbLf) _
        & vbTab & "see details in sheet [" & mk_Wsh & "]", vbInformation, mk_MsgTtl)
                   
    End Sub

…

Private Function Folders_ƒGet_From_User(aFolders As Variant) As Boolean
Dim aFdrs As Variant
Dim oFdr As Object, sFolder As String, blSubFdrs As Boolean
    
    Erase aFolders
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Function
        sFolder = .SelectedItems(1)
    End With
    
    If MsgBox("Do you want to include subfolders?", _
        vbQuestion + vbYesNo + vbDefaultButton2, _
            mk_MsgTtl) = vbYes Then blSubFdrs = True

    Set oFdr = mo_Fso.GetFolder(sFolder)
    
    Select Case blSubFdrs
    
    Case False
        
        If oFdr.Files.Count > 0 Then
            aFdrs = aFdrs & "|" & oFdr.Path
        
        Else
            MsgBox "No files found in folder:" & String(2, vbLf) & _
                        vbTab & sFolder & String(2, vbLf) & _
                            vbTab & "Process is being terminated.", _
                                vbInformation, mk_MsgTtl
            Exit Function
        
        End If
        
    Case Else
        
        Call SubFolders_Get_Array(aFdrs, oFdr)

        If aFdrs = vbNullString Then
            MsgBox "No files found in folder & subfolders:" & String(2, vbLf) & _
                        vbTab & sFolder & String(2, vbLf) & _
                            vbTab & "Process is being terminated.", _
                                vbInformation, mk_MsgTtl
            Exit Function
    
        End If
        
    End Select
    
    Rem String To Array
    aFdrs = Mid(aFdrs, 2)
    aFdrs = Split(aFdrs, "|")
    aFolders = aFdrs
    
    Folders_ƒGet_From_User = True
    
    End Function

…

Private Sub SubFolders_Get_Array(aFdrs As Variant, oFdr As Object)
Dim oSfd As Object
    
    With oFdr
        If .Files.Count > 0 Then aFdrs = aFdrs & "|" & .Path
        For Each oSfd In .SubFolders
            Call SubFolders_Get_Array(aFdrs, oSfd)
    Next: End With
    
    End Sub

…

Private Sub Files_Get_Array(aFiles As Variant)
Dim lRow As Long
    
    With ThisWorkbook.Sheets("DATA")  'change as required
        lRow = .Rows.Count
        If Len(.Cells(lRow, 1).Value) = 0 Then lRow = .Cells(lRow, 1).End(xlUp).Row
        aFiles = .Cells(2, 1).Resize(-1 + lRow, 7).Value
    End With

    End Sub

…

Private Function Files_ƒRename(aRenamed As Variant, aFolders As Variant, aFiles As Variant) As Boolean
Dim vRcd As Variant:    vRcd = Array("Filename.Old", "Filename.New")
Dim blRenamed As Boolean
Dim oDtn As Object, aRcd() As String, lRow As Long, bFdr As Byte
Dim sNameOld As String, sNameNew As String
Dim sFilename As String, sResult As String
    
    aRenamed = vbNullString
    
    Set oDtn = CreateObject("Scripting.Dictionary")
    vRcd = Join(vRcd, "|") & "|" & Join(aFolders, "|")
    vRcd = Split(vRcd, "|")
    oDtn.Add 0, vRcd
                    
    With mo_Fso
        
        For lRow = 1 To UBound(aFiles)

            sNameOld = aFiles(lRow, 1)
            sNameNew = aFiles(lRow, 7)
            vRcd = sNameOld & "|" & sNameNew
            
            For bFdr = 0 To UBound(aFolders)
            
                sResult = Chr(39)
                sFilename = .BuildPath(aFolders(bFdr), sNameOld)
                            
                If .FileExists(sFilename) Then
    
                    If File_ƒRename_Apply(sResult, sNameNew, sFilename) Then blRenamed = True
            
                End If
            
                vRcd = vRcd & "|" & sResult
            
            Next
           
            vRcd = Mid(vRcd, 2)
            vRcd = Split(vRcd, "|")
            oDtn.Add lRow, vRcd
    
    Next: End With
    
    If Not (blRenamed) Then Exit Function
    
    aRenamed = oDtn.Items
    aRenamed = WorksheetFunction.Index(aRenamed, 0, 0)
    Files_ƒRename = True
    
    End Function

…

Private Function File_ƒRename_Apply(sResult As String, sNameNew As String, sFileOld As String) As Boolean
    
    With mo_Fso.GetFile(sFileOld)
        
        sResult = .ParentFolder
        On Error Resume Next
        .Name = sNameNew
        If Err.Number <> 0 Then
            sResult = "¡Err: " & Err.Number & " - " & Err.Description
            Exit Function
        End If
        On Error GoTo 0
    
    End With
            
    File_ƒRename_Apply = True
    
    End Function

…

Private Sub File_Rename_Post_Records(aFiles As Variant, aRenamed As Variant)
Const kLob As String = "lo.Audit"
Dim blWshNew As Boolean
Dim Wsh As Worksheet, Lob As ListObject, lRow As Long
    
    Rem Worksheet Set\Add
    With ThisWorkbook
        
        On Error Resume Next
        Set Wsh = .Sheets(mk_Wsh)
        On Error GoTo 0
        
        If Wsh Is Nothing Then
            
            .Worksheets.Add After:=.Sheets(.Sheets.Count)
            Set Wsh = .Sheets(.Sheets.Count)
            blWshNew = True
        
    End If: End With
        
    Rem Set ListObject
    With Wsh
        
        .Name = mk_Wsh
        .Activate
        Application.GoTo .Cells(1), 1
        
        Select Case blWshNew
        
        Case False
            
            Set Lob = .ListObjects(kLob)
            lRow = 1 + Lob.ListRows.Count

        Case Else

            With .Cells(2, 2).Resize(1, 4)
                .Value = Array("TimeStamp", "Filename.Old", "Filename.New", "Folder.01")
                Set Lob = .Worksheet.ListObjects.Add(xlSrcRange, .Resize(2), , xlYes)
                Lob.Name = "lo.Audit"
                lRow = 1
            
    End With: End Select: End With
        
    Rem Post Data
    With Lob.DataBodyRange.Cells(lRow, 1).Resize(UBound(aRenamed), 1)
        .Value = Format(Now, "YYYYMMDD_HHMMSS")
        .Offset(0, 1).Resize(, UBound(aRenamed, 2)).Value = aRenamed
        .CurrentRegion.Columns.AutoFit
    End With
    
    End Sub

Answer 2

Renaming Files (Subfolders)

• Not nearly enough tested.
• You better create a copy of the folder where it should run to avoid losing files.
• It will write all files in the folder and its subfolders to a dictionary object whose keys (file paths) will be checked against the file paths in column A. If matched, the files will be renamed to the name in column G with the same file path.
• It checks each new file path only against the file paths in the dictionary before renaming.
• It will fail if a file name is not valid.
• Copy the complete code to a standard module, e.g. Module1.
• Adjust the values in the constants section of the first procedure.
• Run only the first procedure, the rest is being called by it.

The Code

Option Explicit

Sub renameFiles()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstRow As Long = 2
    Dim Cols As Variant
    Cols = Array("A", "G")
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define worksheet.
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    ' Define Lookup Column Range.
    Dim rng As Range
    Set rng = defineColumnRange(ws, Cols(LBound(Cols)), FirstRow)
    ' Write values from Column Ranges to jagged Column Ranges Array.
    Dim ColumnRanges As Variant
    ColumnRanges = getColumnRanges(rng, Cols)
    
    ' Pick a folder.
    Dim FolderPath As String
    FolderPath = pickFolder
    
    ' Define a Dictionary object.
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    ' Write the paths and the names of the files in the folder
    ' and its subfolders to the Dictionary.
    Set dict = getFilesDictionary(FolderPath)
    
    ' Rename files.
    Dim RenamesCount As Long
    RenamesCount = renameColRngDict(ColumnRanges, dict)

    ' Inform user.
    If RenamesCount > 0 Then
        MsgBox "Renamed " & RenamesCount & " file(s).", vbInformation, "Success"
    Else
        MsgBox "No files renamed.", vbExclamation, "No Renames"
    End If
    
End Sub

Function defineColumnRange(Sheet As Worksheet, _
                           ColumnIndex As Variant, _
                           FirstRowNumber As Long) _
  As Range
    Dim rng As Range
    Set rng = Sheet.Cells(FirstRowNumber, ColumnIndex) _
                   .Resize(Sheet.Rows.Count - FirstRowNumber + 1)
    Dim cel As Range
    Set cel = rng.Find(What:="*", _
                       LookIn:=xlFormulas, _
                       SearchDirection:=xlPrevious)
    If Not cel Is Nothing Then
        Set defineColumnRange = rng.Resize(cel.Row - FirstRowNumber + 1)
    End If
End Function

Function getColumnRanges(ColumnRange As Range, _
                         BuildColumns As Variant) _
  As Variant
    Dim Data As Variant
    ReDim Data(LBound(BuildColumns) To UBound(BuildColumns))
    Dim j As Long
    With ColumnRange.Columns(1)
        For j = LBound(BuildColumns) To UBound(BuildColumns)
            If .Rows.Count > 1 Then
                Data(j) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
                  .Column - .Column).Value
            Else
                Dim OneCell As Variant
                ReDim OneCell(1 To 1, 1 To 1)
                Data(j) = OneCell
                Data(1, 1) = .Offset(, .Worksheet.Columns(BuildColumns(j)) _
                  .Column - .Column).Value
            End If
        Next j
    End With
    getColumnRanges = Data
End Function

Function pickFolder() _
  As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            pickFolder = .SelectedItems(1)
        End If
    End With
End Function

' This cannot run without the 'listFiles' procedure.
Function getFilesDictionary(ByVal FolderPath As String) _
  As Object
    Dim dict As Object ' ByRef
    Set dict = CreateObject("Scripting.Dictionary")
    With CreateObject("Scripting.FileSystemObject")
        listFiles dict, .GetFolder(FolderPath)
    End With
    Set getFilesDictionary = dict
End Function

' This is being called only by 'getFileDictionary'
Sub listFiles(ByRef Dictionary As Object, _
              fsoFolder As Object)
    Dim fsoSubFolder As Object
    Dim fsoFile As Object
    For Each fsoFile In fsoFolder.Files
        Dictionary(fsoFile.Path) = Empty 'fsoFile.Name
    Next fsoFile
    For Each fsoSubFolder In fsoFolder.SubFolders
        listFiles Dictionary, fsoSubFolder
    Next
End Sub

' Breaking the rules:
' A Sub written as a function to return the number of renamed files.
Function renameColRngDict(ColumnRanges As Variant, _
                          Dictionary As Object) _
  As Long
    Dim Key As Variant
    Dim CurrentIndex As Variant
    Dim NewFilePath As String
    For Each Key In Dictionary.Keys
        Debug.Print Key
        CurrentIndex = Application.Match(Key, _
          ColumnRanges(LBound(ColumnRanges)), 0)
        If Not IsError(CurrentIndex) Then
            NewFilePath = Left(Key, InStrRev(Key, Application.PathSeparator)) _
              & ColumnRanges(UBound(ColumnRanges))(CurrentIndex, 1)
            If IsError(Application.Match(NewFilePath, Dictionary.Keys, 0)) Then
                renameColRngDict = renameColRngDict + 1
                Name Key As NewFilePath
            End If
        End If
    Next Key
End Function