VBA Batch rename workbooks based on cell value

[rplohocky]

Hello,
I am using a piece of code that opens every workbook in a folder then performs a function (i.e. inserts a formula) then closes. I am looking for a way to rename the workbook based on the value found in BI2 without creating a duplicate workbook which is what happens when do a savas. If this is not possible, I could use another macro to loop through and rename them after the first macro runs but I would prefer to save a bit of time if possible.

Here is the looping code I use to insert a formula to each workbook.

<code>
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: [URL="http://www.TheSpreadsheetGuru.com"]www.TheSpreadsheetGuru.com[/URL]

Dim WB As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & ""
    End With

'In Case of Cancel
NextCode:
  myPath = "C:\Users\RPlohocky\Desktop\Emailed Temp Files\Lisa Anderson\New Project\3087 Invoices"
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xlsx*"

'Target Path with Ending Extention
  myfile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myfile <> ""
    'Set variable equal to opened workbook
      Set WB = Workbooks.Open(Filename:=myPath & myfile)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents


    '**********ADD CODE IN THIS AREA****************************************
    'Change First Worksheet's Background Fill Blue
      WB.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
      
    Range("BF2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-52],8)"
    Range("BG2").Select
    ActiveCell.FormulaR1C1 = _
        "=LEFT(RC[-56],4)&""-""&MID(RC[-56],5,2)&""-""&RIGHT(RC[-56],2)&""-"""
    Range("BH2").Select
    ActiveCell.FormulaR1C1 = "=RC[-56]"
    Range("BI2").Select
    ActiveCell.FormulaR1C1 = "=CONCAT(RC[-3],RC[-2],RC[-1])"
    Range("BI3").Select

***************************************************************************
    
    'Save and Close Workbook
      WB.Close SaveChanges:=True
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myfile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

</code>

Thanks for any help!

 

[John_w]

Untested - so try this on a copy of the target folder - but try replacing the WB.Close with these lines:

    Dim newFileName As String
    newFileName = ActiveSheet.Range("BI2").Value

    'Save and Close Workbook
    WB.Close SaveChanges:=True
    
    'Rename with new file name
    Name myPath & myFile As myPath & newFileName & Mid(myFile, InStrRev(myFile, "."))

 

[rplohocky]

Untested - so try this on a copy of the target folder - but try replacing the WB.Close with these lines:

    Dim newFileName As String
    newFileName = ActiveSheet.Range("BI2").Value

    'Save and Close Workbook
    WB.Close SaveChanges:=True
    
    'Rename with new file name
    Name myPath & myFile As myPath & newFileName & Mid(myFile, InStrRev(myFile, "."))

OMG!!! It worked perfectly, thank you!!! Excel is so cool!