VBA code to rename all files in a folder with another file extension

[Excelpromax123]

Hello everyone. I need a code to rename the file extension of all files in a specified directory to another filename. Example: *abc
Illustration: rename the file extension of all files ( *xls,xlsx, xlsb, txt, docx, exe, JPG,png..Any file extension ) of the path "C:\Users\PC\ Desktop\TEST" change the file extension to *ABC
Note: If in the path "C:\Users\PC\ Desktop\TEST" there is a subfolder and there are files inside, it will also change the file extension to *ABC
Sincerely thank

 

[Zot]

Create a macro workbook and copy this macro

Option Compare Text

Sub CopySheetToClosedWB()

LoopAllFolderAndSub ("C:\Users\PC\ Desktop\TEST\")

End Sub

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String, Folds() As String, FileNoExt As String
Dim i As Long, nFold As Long
Dim wb As Workbook, wbPrg As Workbook

Set wbPrg = ActiveWorkbook

Application.ScreenUpdating = False

If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            FileNoExt = Left(FullFPath, InStrRev(FullFPath, ".") - 1)
            Name FullFPath As FileNoExt & ".ABC"
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
wbPrg.Close False

End Sub

 

[Excelpromax123]

The code runs very well. thank you. In case I want to change the name of the file, where should I edit the code in ascending order?
after renaming the file extension to "*.ABC", then continue to rename the file to data1, data2...so as not to have the same name
Eg:

 

[Excelpromax123]

Create a macro workbook and copy this macro

Option Compare Text

Sub CopySheetToClosedWB()

LoopAllFolderAndSub ("C:\Users\PC\ Desktop\TEST\")

End Sub

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String, Folds() As String, FileNoExt As String
Dim i As Long, nFold As Long
Dim wb As Workbook, wbPrg As Workbook

Set wbPrg = ActiveWorkbook

Application.ScreenUpdating = False

If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            FileNoExt = Left(FullFPath, InStrRev(FullFPath, ".") - 1)
            Name FullFPath As FileNoExt & ".ABC"
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
wbPrg.Close False

End Sub

The code only works well with the file name in English, other languages the code cannot run. Please fix the code to run all languages
Please help me edit the code. Sincerely thank

 

[Zot]

Can make it in one go like this

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String, Folds() As String, FileNoExt As String
Dim i As Long, m As Long, nFold As Long
Dim wb As Workbook, wbPrg As Workbook

Set wbPrg = ActiveWorkbook

Application.ScreenUpdating = False

If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

m = 0
While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            m = m + 1
            Name FullFPath As FPath & "Data" & m & ".ABC"
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
wbPrg.Close False

End Sub

 

[Excelpromax123]

Can make it in one go like this

Sub LoopAllFolderAndSub(ByVal FPath As String)

Dim FName As String, FullFPath As String, Folds() As String, FileNoExt As String
Dim i As Long, m As Long, nFold As Long
Dim wb As Workbook, wbPrg As Workbook

Set wbPrg = ActiveWorkbook

Application.ScreenUpdating = False

If Right(FPath, 1) <> "\" Then FPath = FPath & "\"
FName = Dir(FPath & "*.*", vbDirectory)

m = 0
While Len(FName) <> 0
    If Left(FName, 1) <> "." Then
        FullFPath = FPath & FName
        If (GetAttr(FullFPath) And vbDirectory) = vbDirectory Then
            ReDim Preserve Folds(0 To nFold) As String
            Folds(nFold) = FullFPath
            nFold = nFold + 1
        Else
            m = m + 1
            Name FullFPath As FPath & "Data" & m & ".ABC"
        End If
    End If
    FName = Dir()
Wend

For i = 0 To nFold - 1
    LoopAllFolderAndSub Folds(i)
Next i
wbPrg.Close False

End Sub

The code runs very well. But Code only works well with English names, because I have many files with Chinese and Japanese languages, so the code cannot run. Please help me fix the code that works fine on all files regardless of language. Sincerely thank

 

[Zot]

Oh... I forget about the other requirement you mentioned.

The problem is caused VBA not supporting unicode. I think the way to solve this is by calling Windows script. Try if this works

Public n As Long

Sub RenameFileInFolderAndSbbFolder()

Dim FSO As Object
Dim FSOFolder As Object
Dim FoldName As String

Set FSO = CreateObject("Scripting.FileSystemObject")

'Set Folder Path here
FoldName = "C:\Users\MrExcel\Test\"

LoopSubFolder FSO.GetFolder(FoldName)

End Sub

Sub LoopSubFolder(FSOFolder As Object)

Dim FName As String
Dim FSO As Object
Dim FSOSubFolder As Object
Dim FSOFile As Object

Set FSO = CreateObject("Scripting.FileSystemObject")

For Each FSOSubFolder In FSOFolder.Subfolders
    LoopSubFolder FSOSubFolder
Next

' Rename Files
For Each FSOFile In FSOFolder.Files
    n = n + 1
    Name FSOFile As FSO.GetFolder(FSOFolder) & "\" & "Data" & n & ".ABC"
Next

End Sub