使用 VBA 中同一工作表中的单元格值重命名 Excel 中的多个工作表

Question

I am currently working on a VBA project. I have a workbook with multiple tabs from different workbooks. The names of all the tabs are the same, however since they come from different files, I would like to name them based on the filenames they are extracted from. The filenames are present in the cell EC1 of every tab. I would like to name all the sheets in the workbook based on the value present in cell EC1 of each individual sheet.

I have the following code:

Sub RenameSheet()
    Dim rs As Worksheet
    For Each rs In Sheets
    rs.Name = rs.Range("EC1")
    Next rs
End Sub

I have been getting a 1004 error from the above code.

I tried this code too:

Sub RenameSheet()
    Dim xWs As Worksheet
    Dim xRngAddress As String
    Dim xName As String
    Dim xSSh As Worksheet
    Dim xInt As Integer
    xRngAddress = Application.ActiveCell.Address
    On Error Resume Next
    Application.ScreenUpdating = False
    For Each xWs In Application.ActiveWorkbook.Sheets
        xName = xWs.Range(xRngAddress).Value
        If xName <> "" Then
            xInt = 0
            Set xSSh = Nothing
            Set xSSh = Worksheets(xName)
            While Not (xSSh Is Nothing)
                Set xSSh = Nothing
                Set xSSh = Worksheets(xName & "(" & xInt & ")")
                xInt = xInt + 1
            Wend
            If xInt = 0 Then
                xWs.Name = xName
            Else
                If xWs.Name <> xName Then
                    xWs.Name = xName & "(" & xInt & ")"
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Some sheets do get renamed, however some do not. I have checked for duplicate sheet names, and there are none. I have also checked if the filename is in the correct range (cell), and it is present.

Answer 1

There might be problems with the value if it contains some special characters. The excel sheets can have some restrictions for their names, if thats the problem, my code could be the solution. It cuts the string to a maximum length of 31 chars and deletes all the special chars which are not allowed in names.

Sub RenameSheet()

Dim rs As Worksheet

For Each rs In Sheets
sheetName = without_special_chars(rs.Range("EC1").Value)
If Len(sheetName) > 31 Then
    sheetName = Left(sheetName, 31)
End If
rs.Name = sheetName
Next rs

End Sub

Function without_special_chars(text As String) As String
Dim i As Integer
Const special_chars As String = "-.,:;#+ß'*?=)(/&%$§!~\}][{"
For i = 1 To Len(special_chars)
text = Replace(text, Mid(special_chars, i, 1), "")
Next i
without_special_chars = text
End Function

Answer 2

Rename Multiple Worksheets

A Quick Fix

• Your first code should have been something like this:

   Sub renameWorksheetsQF() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Name = ws.Range("EC1").Value Next ws End Sub

  Note the not so subtile differences.

In Depth

Option Explicit

Sub renameWorksheets()

    On Error GoTo clearError
    Const cAddress As String = "A1" ' "EC1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim ws As Worksheet
    Dim cel As Range
    Dim oName As String
    Dim nName As String
    
    For Each ws In wb.Worksheets
        oName = ws.Name
        Set cel = ws.Range(cAddress)
        If IsError(cel) Then
            Debug.Print "Cell '" & cAddress & "' in worksheet '" _
                & oName & "' contains the error value '" & cel.Text & "'."
        Else
            If IsEmpty(cel) Then
                Debug.Print "Cell '" & cAddress & "' in worksheet '" _
                    & oName & "' is an empty cell."
            Else
                nName = CStr(cel.Value)
                On Error GoTo RenameError
                If oName <> nName Then
                    ws.Name = nName
                Else
                    Debug.Print "Worksheet '" & oName _
                        & "' had previously been renamed."
                End If
                On Error GoTo clearError
            End If
        End If
    Next ws
    
ProcExit:
    Exit Sub

RenameError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Debug.Print "     Could not rename '" & oName & "' to '" & nName & "'."
    Resume Next
clearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Debug.Print "     Unexpected error."
    Resume ProcExit
End Sub