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

Question

我目前正在研究 VBA 項目。 我有一個工作簿，其中包含來自不同工作簿的多個選項卡。 所有選項卡的名稱都是相同的，但是由於它們來自不同的文件，我想根據提取它們的文件名來命名它們。 文件名存在於每個選項卡的單元格 EC1 中。 我想根據每個工作表的單元格 EC1 中存在的值來命名工作簿中的所有工作表。

我有以下代碼：

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

我從上面的代碼中得到了 1004 錯誤。

我也試過這段代碼：

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

有些工作表確實被重命名，但有些則沒有。 我檢查了重復的工作表名稱，但沒有。 我還檢查了文件名是否在正確的范圍（單元格）內，並且它存在。

Answer 1

如果該值包含一些特殊字符，則可能存在問題。 excel 表的名稱可能有一些限制，如果這是問題，我的代碼可能是解決方案。 它將字符串剪切到最大長度為 31 個字符，並刪除名稱中不允許的所有特殊字符。

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

重命名多個工作表

快速修復

• 您的第一個代碼應該是這樣的：

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

  請注意不那么微妙的差異。

深入

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