Using Excel Macro to Rename Files

[Gooby]

Hello,

I have tried using some of the VBA code provided in other threads and sources. However, I am unable to get them to work with what I want to do and my limited vba knowledge so any help would be greatly appreciated.

I would like to rename PDF files located within a folder on my desktop. Within this folder are multiple subfolders (01, 02, 03, up to 24, but not always).

I want to automatically rename these files by adding a prefix and suffix to the existing filename. Both the prefix and suffix will come from data inputted in two separate cells (A2, B2). A2 = prefix, B2 = suffix. However, I also want the code to pull the subfolder name (01, 02, 03 and so on) and include it as part of the prefix. Additionally, I need a 3 digit sequential number as part of the prefix, but the sequential number will depend on the number of documents within each subfolder. Therefore, I would like to determine the starting sequential number for each subfolder with it going up by 1 automatically for each file thereafter, within the corresponding subfolder.

Test Book.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z
1	Prefix	Suffix	01	02	03	04	05	06	07	08	09	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24
2	25678	Some text or numbers	005	004	001	008	009	010	005	002	001	001	003	004	005	002
3
4
5
6		Example filename in subfolder 01 would be Someagreement.pdf
7		VBA macro would automatically rename it to 25678-01-005 Someagreement Some text or numbers.pdf
8
Sheet1

So the end result would look something like (prefix-subfolder name-sequence number)(original filename)(suffix).pdf
Example root folder can be seen below.

If possible, I would like the macro to work with however many subfolders there are and not be limited to a predefined number.

It would be amazing if this can be done and I would appreciate the help anyone can provide. Please let me know if further clarification is needed and I'll do my best to explain. Thank you!

 

[I_know_nuffin]

try the below

you will need to pull suffix and prefix from your sheet

Function GetFilesIn(folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(folder & "\*")
  Do While F <> ""
    GetFilesIn.Add F
    F = Dir
  Loop
End Function

Function GetFoldersIn(folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(folder & "\*", vbDirectory)
  Do While F <> ""
    If GetAttr(folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
    F = Dir
  Loop
End Function

Sub Testrenamefiles()
  Dim Cfiles As Collection, Ffiles
  Dim Cfolder As Collection, Ffolder
  Dim path As String, newpath As String
  Dim prefix As String, suffix As String
  Dim newprefix As String, x As Integer
  Dim fext As String, fname As String
  
  
  prefix = "ABCDEF" ' pull this from your sheet rather than hard coded
  
  suffix = "abcdef12345" ' pull this from your sheet rather than hard coded
  
  path = "C:\xxx\yyy\Folders\testfolder\"
  

'  Debug.Print
  Debug.Print "Folders in " & path
  Set Cfolder = GetFoldersIn(path)
  For Each Ffolder In Cfolder
  x = 0 ' reset file counter
    Debug.Print Ffolder
    newpath = path & Ffolder
    Debug.Print newpath
    Set Cfiles = GetFilesIn(newpath)
    Debug.Print Cfiles.Count
    
    For Each Ffiles In Cfiles
    x = x + 1
    
      Debug.Print Ffiles
      fname = Left(Ffiles, InStr(1, Ffiles, ".") - 1)
      fext = Mid(Ffiles, InStr(1, Ffiles, "."), 5)
      
      newprefix = prefix & "-" & Ffolder & "-" & Format(x, "000")
      
      
      Name newpath & "\" & Ffiles As newpath & "\" & newprefix & "-" & fname & " " & suffix & fext
      
    Next Ffiles
    
    
    
  Next Ffolder
  

  
  
End Sub

 

[Gooby]

try the below

you will need to pull suffix and prefix from your sheet

Function GetFilesIn(folder As String) As Collection
  Dim F As String
  Set GetFilesIn = New Collection
  F = Dir(folder & "\*")
  Do While F <> ""
    GetFilesIn.Add F
    F = Dir
  Loop
End Function

Function GetFoldersIn(folder As String) As Collection
  Dim F As String
  Set GetFoldersIn = New Collection
  F = Dir(folder & "\*", vbDirectory)
  Do While F <> ""
    If GetAttr(folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
    F = Dir
  Loop
End Function

Sub Testrenamefiles()
  Dim Cfiles As Collection, Ffiles
  Dim Cfolder As Collection, Ffolder
  Dim path As String, newpath As String
  Dim prefix As String, suffix As String
  Dim newprefix As String, x As Integer
  Dim fext As String, fname As String
 
 
  prefix = "ABCDEF" ' pull this from your sheet rather than hard coded
 
  suffix = "abcdef12345" ' pull this from your sheet rather than hard coded
 
  path = "C:\xxx\yyy\Folders\testfolder\"
 

'  Debug.Print
  Debug.Print "Folders in " & path
  Set Cfolder = GetFoldersIn(path)
  For Each Ffolder In Cfolder
  x = 0 ' reset file counter
    Debug.Print Ffolder
    newpath = path & Ffolder
    Debug.Print newpath
    Set Cfiles = GetFilesIn(newpath)
    Debug.Print Cfiles.Count
   
    For Each Ffiles In Cfiles
    x = x + 1
   
      Debug.Print Ffiles
      fname = Left(Ffiles, InStr(1, Ffiles, ".") - 1)
      fext = Mid(Ffiles, InStr(1, Ffiles, "."), 5)
     
      newprefix = prefix & "-" & Ffolder & "-" & Format(x, "000")
     
     
      Name newpath & "\" & Ffiles As newpath & "\" & newprefix & "-" & fname & " " & suffix & fext
     
    Next Ffiles
   
   
   
  Next Ffolder
 

 
 
End Sub

Thank you for this. I will give it a go. If I don't respond it means it worked! Thanks again.