Renaming files within Sub folders

[shellzAus]

Hi, I am looking for some help to adjust this VBA. I use this to rename files within a folder, but it only works for the files listed in the main folder. How can I modify this code to rename files that are located in the subfolders too? Thanks in advance

[FONT=&quot]Sub rename_folder()[/FONT]
[FONT=&quot]Const FILEPATH As String = "C:\test"[/FONT]
[FONT=&quot]Dim strfile As String[/FONT]
[FONT=&quot]Dim filenum As String[/FONT]
[FONT=&quot]strfile = Dir(FILEPATH)[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Dim old_name, new_name As String[/FONT]
[FONT=&quot]For i = 2 To Sheets(1).Range("a1").End(xlDown).Row[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]strOldDirName = FILEPATH & Sheets(1).Cells(i, 1).Value[/FONT]
[FONT=&quot]strNewDirName = FILEPATH & Sheets(1).Cells(i, 3).Value[/FONT]
[FONT=&quot]Name strOldDirName As strNewDirName[/FONT]
[FONT=&quot] [/FONT]
[FONT=&quot]Next i[/FONT]
[FONT=&quot]End Sub[/FONT]
[FONT=&quot] [/FONT]

 

[Meesam_ali]

Use below subroutine. I use it so many times and enjoy it everytime. First part (macro) is for getting all the file names to excel (from any selected directory) and then second part renames files as per your requirement in Column-B.
<code>
Sub FileNametoExcel()

Dim fnam As Variant
' fnam is an array of files returned from GetOpenFileName
' note that fnam is of type boolean if no array is returned.
' That is, if the user clicks on cancel in the file open dialog box, fnam is set to FALSE

Dim b As Integer 'counter for filname array
Dim b1 As Integer 'counter for finding \ in filename
Dim c As Integer 'extention marker

' format header
Range("A1").Select
ActiveCell.FormulaR1C1 = "Path and Filenames that had been selected to Rename"
Range("A1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
Columns("A:A").EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "Input New Filenames Below"
Range("B1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
Columns("B:B").EntireColumn.AutoFit

' first open a blank sheet and go to top left ActiveWorkbook.Worksheets.Add

fnam = Application.GetOpenFilename("all files (*.*), *.*", 1, _
"Select Files to Fill Range", "Get Data", True)

If TypeName(fnam) = "Boolean" And Not (IsArray(fnam)) Then Exit Sub

'if user hits cancel, then end

For b = 1 To UBound(fnam)
' print out the filename (with path) into first column of new sheet
ActiveSheet.Cells(b + 1, 1) = fnam(b)
Next


End Sub


Sub RenameFile()
Dim z As String
Dim s As String
Dim V As Integer
Dim TotalRow As Integer


TotalRow = ActiveSheet.UsedRange.Rows.Count


For V = 1 To TotalRow


' Get value of each row in columns 1 start at row 2
z = Cells(V + 1, 1).Value
' Get value of each row in columns 2 start at row 2
s = Cells(V + 1, 2).Value


Dim sOldPathName As String
sOldPathName = z
On Error Resume Next
Name sOldPathName As s


Next V


MsgBox "Congratulations! You have successfully renamed all the files"


End Sub
</code>