Rename Multiple Excel Workbooks based on cell contents

[Scott Campbell]

I have the following code below that is designed to save the active worksheet
based on cell contents.

I have a file with hundreds of workbooks that need to be renamed. Is there
a way to add to this code to make it so that all files in a specific folder
get rename based on the cell contents?

Here is the code:

sub save_it()
dim fname
with activeworkbook
fname = “SL-“.worksheets("sheet1").range("F4").value & _
.worksheets("sheet1").range("F3").value &
_.worksheets(“Sheet1â€).range(“F1â€).value &_
".xls"

..saveas fname
end with
end sub

Thanks for the help.

 

[Rodrigo Ferreira]

If the oldname and new name is in only one file, you can try something like
this

Sub save_it()

Dim NewName As String
Dim OldName As String
Dim FilePath As String
Dim countRow As Integer
Dim LastRow As Integer
Dim objSheet As Worksheet
Dim objWb As Workbook

Set objSheet = ActiveWorkbook.Sheets(1)

FilePath = objSheet.Parent.Path
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

objSheet.Range("A" & objSheet.Rows.Count).Activate
Selection.End(xlUp).Activate
LastRow = ActiveCell.Row

For countRow = 2 To LastRow
OldName = objSheet.Range("A" & countRow).Value 'the old name is in
column A
NewName = objSheet.Range("B" & countRow).Value 'the new name is in
column B
Set objWb = Workbooks.Open(FilePath & OldName)

objWb.Activate
objWb.SaveAs FilePath & NewName
objWb.Close
Kill FilePath & OldName
Set objWb = Nothing
Next

End Sub

If the new name is in the workbook that you have to rename, you can change
the line:
NewName = objSheet.Range("B" & countRow).Value
to something like this:

Set objWb = Workbooks.Open(FilePath & OldName)
objWb.Activate
NewName = "SL -" & objWb.Worksheets("sheet1").Range("F4").Value & _
objWb.Worksheets("sheet1").Range("F3").Value & _
objWb.Worksheets("Sheet1").Range("F1").Value & _
".xls"

 

[Scott Campbell]

I probably didn't describe my task properly.

I have a folder that contains hundreds of excel spreadsheets (workbooks).
Each workbook has 1 tab (worksheet)-- Sheet1
Each workbook is named something like "SL-Report 1540435" where the numbers
appear completely random.
Each report is a monthly report for a specific product and a specific country.

I need my macro to rename each workbook based the contents of 3 cells F4
(Product), F3 Month and F1 Country so that it looks something like this
SL-ProductNameMonth200xCountryName

I am thinking that I need some kind of Loop function in VB.

 

[Rodrigo Ferreira]

Sub save_it()

Dim NewName As String
Dim OldName As String
Dim FilePath As String
Dim objWb As Workbook
Dim objFso As Object 'New FileSystemObject
Dim objFolder As Object 'Folder
Dim objFile As Object 'File
Set objFso = CreateObject("Scripting.FileSystemObject")

'FilePath = Folder that have your workbooks
FilePath = "C:\YourFolderThatContainsWorkbooks\"

Set objFolder = objFso.GetFolder(FilePath)

If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"


For Each objFile In objFolder.Files
OldName = objFile.Name
Set objWb = Workbooks.Open(FilePath & OldName)

objWb.Activate
NewName = "SL - " & objWb.Worksheets("sheet1").Range("F4").Value & _
objWb.Worksheets("sheet1").Range("F3").Value & _
objWb.Worksheets("Sheet1").Range("F1").Value & _
".xls"

objWb.SaveAs FilePath & NewName
objWb.Close
Kill FilePath & OldName
Set objWb = Nothing

Next

End Sub

 

[Scott Campbell]

Thank you very much Rodrigo

Sub save_it()

Dim NewName As String
Dim OldName As String
Dim FilePath As String
Dim objWb As Workbook
Dim objFso As Object 'New FileSystemObject
Dim objFolder As Object 'Folder
Dim objFile As Object 'File
Set objFso = CreateObject("Scripting.FileSystemObject")

'FilePath = Folder that have your workbooks
FilePath = "C:\YourFolderThatContainsWorkbooks\"

Set objFolder = objFso.GetFolder(FilePath)

If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"


For Each objFile In objFolder.Files
OldName = objFile.Name
Set objWb = Workbooks.Open(FilePath & OldName)

objWb.Activate
NewName = "SL - " & objWb.Worksheets("sheet1").Range("F4").Value & _
objWb.Worksheets("sheet1").Range("F3").Value & _
objWb.Worksheets("Sheet1").Range("F1").Value & _
".xls"

objWb.SaveAs FilePath & NewName
objWb.Close
Kill FilePath & OldName
Set objWb = Nothing

Next

End Sub