Rename Files & documents with serial Text - numbers inside Sub folders

[Nawilati]

Dear Sirs,

Can any one help me with writing a VBA the code, I need to rename all files & Documents inside the sub folders a with serial Text - numbers, Example : Inside the Admin Letter folder there is three documents (Scan 15, Scan 16, ID) I need the code to rename all these documents as this (Admin Letter " Based on the Sub Folder Name" - 1, Admin Letter -2 , Admin Letter - 3).

Note - There is folders inside the Compensation & Benefits Sub Folder I wanna keep them as they are without Renaming them I Only want to rename the files & Documents

Can You Help me with this Sir ??

Attached Folders structure.

Thanks in Advance

 

[DanteAmor]

Before running the code on your files, run a test on a directory, with test files.
If the result is what you need, then work in your master folder.
The code assumes that the files or documents have an extension, so for example if you have the fiel: scan 15.pdf, the new name will be Admin letter - 1.pdf

Change in the macro "c:\trabajo\" by the name of your master folder.

Sub renaming_multiple_files()
  Dim fso As Object, fldr As Object
  Dim subfldr1 As Object, subfldr2 As Object, xfile As Object
  Dim sPath As String, newName As String
  Dim n As Long
    
  sPath = "C:\trabajo\"                       'Level 1 - Master Folder
  
  Set fso = CreateObject("Scripting.Filesystemobject")
  Set fldr = fso.getfolder(sPath)
  For Each subfldr1 In fldr.subfolders        'Level 2 - Folder
    For Each subfldr2 In subfldr1.subfolders  'Level 3 - Folder
      n = 0
      For Each xfile In subfldr2.Files        'Level 4 - Files
        n = n + 1
        newName = subfldr2.Name & " - " & n & Mid(xfile.Name, InStrRev(xfile.Name, "."))
        Name xfile As subfldr2 & "\" & newName
      Next xfile
    Next subfldr2
  Next subfldr1
End Sub

 

[Nawilati]

Before running the code on your files, run a test on a directory, with test files.
If the result is what you need, then work in your master folder.
The code assumes that the files or documents have an extension, so for example if you have the fiel: scan 15.pdf, the new name will be Admin letter - 1.pdf

Change in the macro "c:\trabajo\" by the name of your master folder.

Sub renaming_multiple_files()
  Dim fso As Object, fldr As Object
  Dim subfldr1 As Object, subfldr2 As Object, xfile As Object
  Dim sPath As String, newName As String
  Dim n As Long
   
  sPath = "C:\trabajo\"                       'Level 1 - Master Folder
 
  Set fso = CreateObject("Scripting.Filesystemobject")
  Set fldr = fso.getfolder(sPath)
  For Each subfldr1 In fldr.subfolders        'Level 2 - Folder
    For Each subfldr2 In subfldr1.subfolders  'Level 3 - Folder
      n = 0
      For Each xfile In subfldr2.Files        'Level 4 - Files
        n = n + 1
        newName = subfldr2.Name & " - " & n & Mid(xfile.Name, InStrRev(xfile.Name, "."))
        Name xfile As subfldr2 & "\" & newName
      Next xfile
    Next subfldr2
  Next subfldr1
End Sub

Dear Sir,

First let me thank you for being very helpful, i run the code but the code stopped working when he find any file aren't a PDF file like ".tif" or ".msg" and it stopped when he find any documents named in Arabic Language !, do you know how we can fix that ?

 

[DanteAmor]

it stopped when he find any documents named in Arabic Language

Those names have an extension?
You could put a picture of some of those names to see what we're up against

 

[Nawilati]

Those names have an extension?
You could put a picture of some of those names to see what we're up against

Those names have an extension?
You could put a picture of some of those names to see what we're up against

Mr. Dante,

after debugging the issue, it's not related to file type it's related to the file naming language as attached below, any ides ??

 

[DanteAmor]

it's not related to file type it's related to the file naming language

اسم الملف
To rename files named in Arabic or any other language.

Before executing the code, I highly recommend making a backup of your files.

Try this:

Sub renaming_multiple_files()
  Dim fso As Object, fldr As Object
  Dim subfldr1 As Object, subfldr2 As Object, xFile As Object
  Dim sPath As String, newName As String, sExt As String, tempPath As String
  Dim n As Long
    
  sPath = "C:\trabajo\"                       'Level 1 - Master Folder
  tempPath = Environ$("temp") & "\"
  
  Set fso = CreateObject("Scripting.Filesystemobject")
  Set fldr = fso.GetFolder(sPath)
  For Each subfldr1 In fldr.subfolders        'Level 2 - Folder
    For Each subfldr2 In subfldr1.subfolders  'Level 3 - Folder
      n = 0
      For Each xFile In subfldr2.Files        'Level 4 - Files
        n = n + 1
        sExt = Mid(xFile.Name, InStrRev(xFile.Name, "."))
        newName = subfldr2.Name & " - " & n & sExt
        Call fso.CopyFile(xFile, tempPath & "temp" & sExt)
        DoEvents
        fso.DeleteFile xFile, True
        DoEvents
        Name tempPath & "temp" & sExt As subfldr2 & "\" & newName
        DoEvents
      Next xFile
    Next subfldr2
  Next subfldr1
End Sub

 

[DanteAmor]

Try this version from 24Jun

Sub renaming_multiple_files()
  Dim fso As Object, fldr As Object
  Dim subfldr1 As Object, subfldr2 As Object, xFile As Object
  Dim sPath As String, newName As String, sExt As String
  Dim n As Long
    
  sPath = "C:\trabajo\"                       'Level 1 - Master Folder
  
  Set fso = CreateObject("Scripting.Filesystemobject")
  Set fldr = fso.GetFolder(sPath)
  For Each subfldr1 In fldr.subfolders        'Level 2 - Folder
    For Each subfldr2 In subfldr1.subfolders  'Level 3 - Folder
      n = 0
      For Each xFile In subfldr2.Files        'Level 4 - Files
        n = n + 1
        sExt = Mid(xFile.Name, InStrRev(xFile.Name, "."))
        newName = subfldr2 & "\" & subfldr2.Name & " - " & n & sExt
        fso.CopyFile xFile, newName
        DoEvents
        If fso.fileexists(newName) Then
          fso.DeleteFile xFile, True
          DoEvents
        End If
      Next xFile
    Next subfldr2
  Next subfldr1
End Sub