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.

VBasic2008 · Accepted Answer

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

Renaming Files in directory not only a folder

Answers (2)

Renaming Files (Subfolders)

Related Questions