• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Need help with macro for changing worksheet name

John1975

New Member
Hi Folks,

I have a close to 300 Excel files in one folder, all these Excel file have worksheet with similar names

I need a macro to change or create a new worksheet name which need to unique (like 1,2,3,4,....300). Can anyone help

Regards
 
Hi John1975,
try this code,
Code:
Sub RenameSheets()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh     As Worksheet
    Dim x      As Integer

    x = 1
    
    Dim ErrorYes As Boolean
    
    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Keetoowah\Desktop\Forum\" 'Adapt your path
    
    
    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    
    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0
            
            If Not mybook Is Nothing Then
                
                
                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                
                
                With mybook
                    
                    
                    For Each sh In ActiveWorkbook.Worksheets
                        
                        sh.Name = x
                        
                        x = x + 1
                    Next sh
                End With
                
                
                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If
            
        Next Fnum
        x = x + 1
        
    End If
    
    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If
    
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
 
Thanks for your efforts in sending this code. However, I'm getting messages"
protected workbook/sheet or a sheet/range that not exist". What son need to ensure in my Excel file so that I do not get this message?
 
Hi John1975,
I tested with some files with different extension (xls, xlsx, xlsm, xlsb) without problems. Have you checked if some of the sheets are renamed? I suggest you to test with few files in a different folder. Also you could change the line
x = 1
with
X = 1000
 
I checked it with few files. All my files had one sheet with sheet name as "sheet1". I was trying to change such sheet names to unique names
 
Hi John1975,
I modified the code slightly, if all your files have a single sheet, the following should do the trick:
Code:
Sub RenameSheets2()
    'https://chandoo.org/forum/threads/need-help-with-macro-for-changing-worksheet-name.43033/

    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh     As Worksheet
    Dim x      As Integer

    x = 1
    
    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Keetoowah\Desktop\Forum\"  'Adapt your path
    
    
    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    
    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0
            
            If Not mybook Is Nothing Then
                
                On Error Resume Next
                
                With mybook.Worksheets(1)                    
                    .Name = x                    
                End With
                x = x + 1
                
                Application.DisplayAlerts = False
                mybook.Close savechanges:=True
                Application.DisplayAlerts = True
            End If
            
        Next Fnum
      
    End If
        
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
 
Back
Top