VBA code to rename the files in a folder as per respective file cell values.

[amaresh achar]

I am looking for VBA code assistance to do the following:

>> I have about 3000 files in a folder (with some random alphanumeric values as file names)
>> Each file has unique values in cells B3, D7, G5 of Sheet1
>> I want a macro to rename each file with respective cell values as "B3_D7_G5"

Thank you so much in advance...!

This post is very much similar to following older post:

VBA for renaming multiple excel files in a folder according to a specific Cell value?

I want a VBA for renaming multiple excel files in a folder according to a specific Cell value in that excel file? Is it possible? if yes then kindly provide VBA code

www.mrexcel.com

 

[I_know_nuffin]

Try the below

Function GetFilesIn(folder As String) As Collection
  Dim f As String
  Set GetFilesIn = New Collection
  f = Dir(folder & "\*.xlsx")
  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 Test_rename_files_based_on_cell_Contents()
  Dim Cfiles As Collection, Ffiles
  Dim Cfolder As Collection, Ffolder
  Dim path As String, newpath As String
  Dim newprefix As String, x As Integer
  Dim fext As String, newfilename As String
  Dim wb As Workbook
 

  path = "C:\xxx\yyy\Folders\testfolder\"
 

  '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
   
   
    If Cfiles.Count > 0 Then
   
    For Each Ffiles In Cfiles
    'x = x + 1
   
    Set wb = Workbooks.Open(newpath & "\" & Ffiles)
    If wb.Sheets.Count >= 1 Then
        newfilename = wb.Sheets("Sheet1").Range("B3").Value & "_" & wb.Sheets("Sheet1").Range("D7").Value & "_" & wb.Sheets("Sheet1").Range("G5").Value
    Else
        newfilename = ""
    End If
    wb.Close False
   
   
      'Debug.Print Ffiles
     
      fext = Mid(Ffiles, InStr(1, Ffiles, "."), 5)
      Name newpath & "\" & Ffiles As newpath & "\" & newfilename & fext
     
    Next Ffiles
    End If
   
  Next Ffolder
 
End Sub

 

[amaresh achar]

Try the below

Function GetFilesIn(folder As String) As Collection
  Dim f As String
  Set GetFilesIn = New Collection
  f = Dir(folder & "\*.xlsx")
  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 Test_rename_files_based_on_cell_Contents()
  Dim Cfiles As Collection, Ffiles
  Dim Cfolder As Collection, Ffolder
  Dim path As String, newpath As String
  Dim newprefix As String, x As Integer
  Dim fext As String, newfilename As String
  Dim wb As Workbook
 

  path = "C:\xxx\yyy\Folders\testfolder\"
 

  '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
  
  
    If Cfiles.Count > 0 Then
  
    For Each Ffiles In Cfiles
    'x = x + 1
  
    Set wb = Workbooks.Open(newpath & "\" & Ffiles)
    If wb.Sheets.Count >= 1 Then
        newfilename = wb.Sheets("Sheet1").Range("B3").Value & "_" & wb.Sheets("Sheet1").Range("D7").Value & "_" & wb.Sheets("Sheet1").Range("G5").Value
    Else
        newfilename = ""
    End If
    wb.Close False
  
  
      'Debug.Print Ffiles
    
      fext = Mid(Ffiles, InStr(1, Ffiles, "."), 5)
      Name newpath & "\" & Ffiles As newpath & "\" & newfilename & fext
    
    Next Ffiles
    End If
  
  Next Ffolder
 
End Sub

Hi, I_know_nuffin... The code is working as I expected... but it opens a random excel file from the path in which this macro file is placed. how to avoid that..??

Thank you so much for the help...

 

[I_know_nuffin]

it should only open 'xlsx' files in the below Folder Path or its subfolders

path = "C:\xxx\yyy\Folders\testfolder\"


tested on my folders and it only opens the files in the test folders