Rename all sheets in a folder based on file name (VBA)

[j_saints]

Hello,

I was hoping someone could help me with this issue, I would like to rename the sheets / tabs based on the file name in bulk.

I have a couple of files in a folder that needs to be renamed. Also, the files are set to read-only so wondering what's the right VBA to run for this?

Thank you!

 

[Dan_W]

So the code below should be able to accomplish the task. It is to note that:

• I have assumed that the filenames are in a pattern similar to INVABCDEF.xls and that the sheet name will simply be the filename minus the extension.
• You need to change the filepath : FilePath = "D:\XLSXTEMP\"
• It will change the name of the first sheet in the workbook. I have added code here that will check to make sure the target worksheet is named something like "Sheet1" or "Sheet2", but have commented it out for now to keep it simple.
• The code starts another instance of Excel. It is important to make sure that that instance of Excel is properly closed down.

Please test this on dummy files first before you use it on your actual files. Make sure you have a backup of your files before running any code over them.

Let me know if it works the way you wanted it to, or if you have any difficulties with it.

Sub ChangeWorksheetNames()
Dim FilePath            As String
Dim FileExtension       As String
Dim FileList            As Variant
Dim Filename            As String
Dim WSName              As String
Dim Counter             As Long

On Error GoTo ErrHandler

FilePath = "D:\XLSXTEMP\"
FileExtension = "xls*"
FileList = GetFileList(FilePath, FileExtension, False)

Dim xlAPP As Application
Set xlAPP = New Excel.Application

For Counter = LBound(FileList) To UBound(FileList)
    DoEvents
    Filename = FileList(Counter)
    WSName = Left(Filename, InStrRev(Filename, ".") - 1)
    Set wb = xlAPP.Workbooks.Open(FilePath & Filename)
   ' If wb.Sheets(1).Name Like "Sheet*" Then
        wb.Sheets(1).Name = WSName
        wb.Save
        wb.Close False
    'End If
Next

ErrHandler:
If Err.Number <> 0 Then
    Debug.Print "[ERROR NO. " & Err.Number & "] " & Err.Description
    Debug.Print "Filename: " & Filename
End If
xlAPP.Quit
Set xlAPP = Nothing
End Sub


Function GetFileList(FolderName As String, Optional FileExtension As String = "*", Optional FullPath As Boolean = False) As Variant
    ' Declares a dynamic array
    Dim FileList()      As String
    Dim tmpFilename     As String
    Dim tmpPath         As String
    Dim Counter         As Long
   
    ' Make any necessary corrections to the path
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
   
    If FullPath = True Then tmpPath = FolderName
   
    tmpFilename = Dir(FolderName & "*." & FileExtension)
   
    ' Populate the dynamic array with filenames with the required file extension
    Do While tmpFilename <> Empty
        Counter = Counter + 1
        ReDim Preserve FileList(1 To Counter)
        FileList(Counter) = tmpPath & tmpFilename
        tmpFilename = Dir
    Loop
   
    ' Return the array
    GetFileList = FileList
End Function

 

[ahmad_p82]

Thanks Dan_W
The code works perfectly.
I only changed a part of it to get the folder name from the user as below:

Sub ChangeWorksheetNames()
Dim FilePath            As String
Dim FileExtension       As String
Dim FileList            As Variant
Dim Filename            As String
Dim Counter             As Long

On Error GoTo ErrHandler

'To set FilePath Manually
'FilePath = "C:\Dropbox\BI\Excel Data Tab\Test1"

'To select Filepath By User
Dim strFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Selet Folder": .AllowMultiSelect = False: .Show
        If .SelectedItems.Count = 0 Then Exit Sub Else strFolder = .SelectedItems(1) & "\"
    End With
    
FilePath = strFolder
FileExtension = "xls*"
FileList = GetFileList(FilePath, FileExtension, False)

Dim xlAPP As Application
Set xlAPP = New Excel.Application

For Counter = LBound(FileList) To UBound(FileList)
    DoEvents
    Filename = FileList(Counter)
    Set wb = xlAPP.Workbooks.Open(FilePath & Filename)
   ' If wb.Sheets(1).Name Like "Sheet*" Then
        wb.Sheets(1).Name = "Sheet 1"
        wb.Save
        wb.Close False
    'End If
Next

ErrHandler:
If Err.Number <> 0 Then
    Debug.Print "[ERROR NO. " & Err.Number & "] " & Err.Description
    Debug.Print "Filename: " & Filename
End If
xlAPP.Quit
Set xlAPP = Nothing
End Sub


Function GetFileList(FolderName As String, Optional FileExtension As String = "*", Optional FullPath As Boolean = False) As Variant
    ' Declares a dynamic array
    Dim FileList()      As String
    Dim tmpFilename     As String
    Dim tmpPath         As String
    Dim Counter         As Long
   
    ' Make any necessary corrections to the path
    If Right(FolderName, 1) <> "\" Then FolderName = FolderName & "\"
   
    If FullPath = True Then tmpPath = FolderName
   
    tmpFilename = Dir(FolderName & "*." & FileExtension)
   
    ' Populate the dynamic array with filenames with the required file extension
    Do While tmpFilename <> Empty
        Counter = Counter + 1
        ReDim Preserve FileList(1 To Counter)
        FileList(Counter) = tmpPath & tmpFilename
        tmpFilename = Dir
    Loop
   
    ' Return the array
    GetFileList = FileList
End Function