Renaming Files in directory not only a folder - excel

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?
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.
Files_Get_Array: Creates and array with all the Filenames to be processed (Old & New)
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.
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