vba to rename files in folders, subfolders and sub-subfolders

[cjcass]

Hi,
I have the code below that does a good job of renaming folders but it only renames one subfolder down in the folder '2023 Test' and I need it to rename files in all the sub-subfolders where they occur.
As you can see I currently specify the folder name in cell D4 then run the code and have to do it for all the folders that have subfolders. Can this be tailored so I can rename all files in the folder '2023 Test' capturing all folders, subfolders and sub-subfolders at once? Note - some folders in '2023 Test' have subfolders and some don't.

Dim fso As Object, fold As Object, fFile As Object
Dim fPath As String, fName As String, newName As String

fPath = "C:\Users\Chris\Desktop\2023 Test\" & Range("D4").Value
cnt = ""

Set fso = CreateObject("Scripting.FileSystemObject")
Set fold = fso.GetFolder(fPath)

For Each fFile In fold.subFolders
cnt = ""

fName = Dir(fFile.Path & "\*Presentation.pptx", vbNormal) 'the files to rename

Do While fName <> ""
newName = "\Test" & ".pptx" 'the new name and file association
Name fFile.Path & "\" & fName As fFile.Path & newName

fName = Dir
cnt = cnt & "i" 'just in case there is more than 1 file in a folder
Loop
Next

End Sub

 

[DanteAmor]

Hi @cjcass. Thanks for posting on the forum.

The following code renamefiles_v1 reads all nested subfolders under the initial "C:\Users\Chris\Desktop\2023 Test\" folder. Then rename all the files.

Copy all the code including the initial lines and the AddSubDir function that is at the end of the code.

'These lines at the beginning of all code
Option Explicit
Dim xfolders As New Collection

Sub renamefiles_v1()
  Dim arch As Variant, xfold As Variant
  Dim sPath As String, newName As String
  
  sPath = "C:\Users\Chris\Desktop\2023 Test\"
  xfolders.Add sPath
  Call AddSubDir(sPath)
  
  For Each xfold In xfolders
    arch = Dir(xfold & "\*Presentation.pptx", vbNormal)  'the files to rename
    Do While arch <> ""
      newName = "\Test" & ".pptx" 'the new name and file association
      Name xfold & "\" & arch As xfold & newName
      arch = Dir()
    Loop
  Next
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

----------------------


I found in your code that you refer to the cnt variable, in case there is more than one file in the same folder, but in the code it is not used, which by the way, if there is more than one file in the same folder with the filename ending with "presentation" your macro sends error.
If you want to correct that part then use the following:

Option Explicit

Dim xfolders As New Collection

Sub renamefiles_v2()
  Dim arch As Variant, xfold As Variant
  Dim sPath As String, newName As String, cnt As String
  Dim i As Long
  
  sPath = "C:\Users\Chris\Desktop\2023 Test\"
  xfolders.Add sPath
  Call AddSubDir(sPath)
  
  For Each xfold In xfolders
    arch = Dir(xfold & "\*Presentation.pptx", vbNormal)  'the files to rename
    i = 0
    cnt = ""
    Do While arch <> ""
      newName = "\Test" & cnt & ".pptx"  'the new name and file association
      Name xfold & "\" & arch As xfold & newName
      i = i + 1
      cnt = i
      arch = Dir()
    Loop
  Next
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

 

[cjcass]

Hi @cjcass. Thanks for posting on the forum.

The following code renamefiles_v1 reads all nested subfolders under the initial "C:\Users\Chris\Desktop\2023 Test\" folder. Then rename all the files.

Copy all the code including the initial lines and the AddSubDir function that is at the end of the code.

'These lines at the beginning of all code
Option Explicit
Dim xfolders As New Collection

Sub renamefiles_v1()
  Dim arch As Variant, xfold As Variant
  Dim sPath As String, newName As String
 
  sPath = "C:\Users\Chris\Desktop\2023 Test\"
  xfolders.Add sPath
  Call AddSubDir(sPath)
 
  For Each xfold In xfolders
    arch = Dir(xfold & "\*Presentation.pptx", vbNormal)  'the files to rename
    Do While arch <> ""
      newName = "\Test" & ".pptx" 'the new name and file association
      Name xfold & "\" & arch As xfold & newName
      arch = Dir()
    Loop
  Next
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

----------------------


I found in your code that you refer to the cnt variable, in case there is more than one file in the same folder, but in the code it is not used, which by the way, if there is more than one file in the same folder with the filename ending with "presentation" your macro sends error.
If you want to correct that part then use the following:

Option Explicit

Dim xfolders As New Collection

Sub renamefiles_v2()
  Dim arch As Variant, xfold As Variant
  Dim sPath As String, newName As String, cnt As String
  Dim i As Long
 
  sPath = "C:\Users\Chris\Desktop\2023 Test\"
  xfolders.Add sPath
  Call AddSubDir(sPath)
 
  For Each xfold In xfolders
    arch = Dir(xfold & "\*Presentation.pptx", vbNormal)  'the files to rename
    i = 0
    cnt = ""
    Do While arch <> ""
      newName = "\Test" & cnt & ".pptx"  'the new name and file association
      Name xfold & "\" & arch As xfold & newName
      i = i + 1
      cnt = i
      arch = Dir()
    Loop
  Next
End Sub
'
Sub AddSubDir(lPath As Variant)
  Dim SubDir As New Collection, DirFile As Variant, sd As Variant
  If Right(lPath, 1) <> "\" Then lPath = lPath & "\"
  DirFile = Dir(lPath & "*", vbDirectory)
  Do While DirFile <> ""
    If DirFile <> "." And DirFile <> ".." Then
      If ((GetAttr(lPath & DirFile) And vbDirectory) = 16) Then
        SubDir.Add lPath & DirFile
      End If
    End If
    DirFile = Dir
  Loop
  For Each sd In SubDir
    xfolders.Add sd
    Call AddSubDir(sd)
  Next
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------

Hi Dante Amor,
That works brilliantly, really slick and quick, I used the 2nd version as you suggested.
Many thanks for your time and help with this solution, it's a great help.
Best Regards,
cjcass