Hello,
I am using a macro to rename all my file in a folder with a specific cell value, the macro also rename the sheetname with the same cell value.
It works fine for what I need, the only drawback is that the macro is sometime terribly slow.
1) Could someone give me some tweak to speed-up a bit this macro ?
2) I would like to make some change to the macro to be able to select only specific file in a folder to be renamed instead of the full content of the folder. Would it be possible ?
Thanks in advance for your help,
Martin
Sub RenameAllExcelFilesInDirectory()
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
filepath = .SelectedItems(1)
End With
Set r = Workbooks.Add.Worksheets(1).Range("A1")
StrFile = Dir(filepath & "\*.*")
Do While Len(StrFile) > 0
strExtension = Split(StrFile, ".")(UBound(Split(StrFile, ".")))
Set wb = Workbooks.Open(filepath & "" & StrFile)
StrNewfullfilename = wb.Sheets(1).Range("B6").Value & "." & strExtension
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("B6")
Next rs
ActiveWorkbook.Save
wb.Close
r.Value = StrFile 'print old name
r.Offset(, 1).Value = StrNewfullfilename 'print new name
Set r = r.Offset(1)
Name filepath & "" & StrFile As filepath & "" & StrNewfullfilename
StrFile = Dir
Loop
ActiveWorkbook.Close False
End Sub
I am using a macro to rename all my file in a folder with a specific cell value, the macro also rename the sheetname with the same cell value.
It works fine for what I need, the only drawback is that the macro is sometime terribly slow.
1) Could someone give me some tweak to speed-up a bit this macro ?
2) I would like to make some change to the macro to be able to select only specific file in a folder to be renamed instead of the full content of the folder. Would it be possible ?
Thanks in advance for your help,
Martin
Sub RenameAllExcelFilesInDirectory()
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
filepath = .SelectedItems(1)
End With
Set r = Workbooks.Add.Worksheets(1).Range("A1")
StrFile = Dir(filepath & "\*.*")
Do While Len(StrFile) > 0
strExtension = Split(StrFile, ".")(UBound(Split(StrFile, ".")))
Set wb = Workbooks.Open(filepath & "" & StrFile)
StrNewfullfilename = wb.Sheets(1).Range("B6").Value & "." & strExtension
Dim rs As Worksheet
For Each rs In Sheets
rs.Name = rs.Range("B6")
Next rs
ActiveWorkbook.Save
wb.Close
r.Value = StrFile 'print old name
r.Offset(, 1).Value = StrNewfullfilename 'print new name
Set r = r.Offset(1)
Name filepath & "" & StrFile As filepath & "" & StrNewfullfilename
StrFile = Dir
Loop
ActiveWorkbook.Close False
End Sub