如果重命名的工作表与其他工作表相同

Question

Sub renameWorksheet()
    
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets
    
        On Error Resume Next
        ws.Name = Range("O11").Value & "-" & Range("N11").Value
        
    Next ws
    
End Sub

因为当我重命名工作表并且有两个或多个工作表名称重复时，出现此错误：

该工作表名称已被占用。尝试另一个

因此，如果工作表名称与其他现有工作表相同，我希望将工作表重命名为“_2”。如何修改检测部分？

---

（更新 1） 我更新了我的代码，发现仍然有错误，有人能给我一些建议吗？

Sub renameWorksheet()

    Dim ws As Worksheet
    
    Dim rename As String
    
    Dim rng As Worksheet
    
    Dim i As Integer
    
    i = 1
    
    For Each ws In ThisWorkbook.Worksheets
 
        rename = rng.Range("O11").Value & "-" & rng.Range("N11").Value & "-" & i
    
        If rename = rng.Name Then
        
            i = i + 1
            
            ws.Name = rename
        Else
        
            ws.Name = rename
                
        End If
        
        rng.Name = rename

    Next ws

End Sub

现在返回错误：

对象变量或未设置块变量

Answer 1

使用增量重命名工作表

1. 循环浏览工作簿中的所有工作表。
2. 从每个工作表的单元格中，它构建一个字符串用作工作表的新名称 (NewName)。
3. 如果新名称与工作表名称相同 (vbTextCompare)，则如果 DoCorrectCase 设置为 True，则会重命名以纠正大小写 (vbBinaryCompare)。最后，它退出了。
4. 如果字符串不相等，它会尝试查找同名的工作表。
5. 如果找不到，它会重命名工作表并退出。
6. 如果找到，它会在新名称的基础上增加一个增量并继续执行第 3 步，直到退出第 3 步或第 5 步。

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In the workbook containing this code, by concatenating values
'               from two cells in each worksheet, uses the concatenated
'               string to rename them.
'               Adds an increment if a sheet with the same name already exists.
' Calls:        'RenameWorksheetWithIncrement'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RenameWorksheets()
    
    Const LeftDelimiter As String = "_"
    Const FirstNewIndex As Long = 2
    Const RightDelimiter As String = ""
    Const DoCorrectCase As Boolean = False
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet
    Dim NewName As String
    
    For Each sws In wb.Worksheets

        NewName = CStr(sws.Range("O11").Value) _
            & "-" & CStr(sws.Range("N11").Value)

        RenameWorksheetWithIncrement sws, NewName, _
            LeftDelimiter, FirstNewIndex, RightDelimiter, DoCorrectCase

    Next sws
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Renames a worksheet. Adds an increment if a sheet
'               with the same name already exists.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub RenameWorksheetWithIncrement( _
        ByRef sws As Worksheet, _
        ByVal NewName As String, _
        ByVal LeftDelimiter As String, _
        ByVal FirstNewIndex As Long, _
        ByVal RightDelimiter As String, _
        Optional ByVal DoCorrectCase As Boolean = False)
    Const ProcName As String = "RenameWorksheetWithIncrement"
    On Error GoTo ClearError

    Dim wb As Workbook: Set wb = sws.Parent
    Dim nName As String: nName = NewName
    Dim nIndex As Long: nIndex = FirstNewIndex
    Dim swsName As String: swsName = sws.Name

    Dim nws As Worksheet

    Do
        ' Test if already renamed.
        If StrComp(swsName, nName, vbTextCompare) = 0 Then ' ignore case
            If DoCorrectCase Then
                If StrComp(swsName, nName, vbBinaryCompare) <> 0 Then
                    sws.Name = nName ' correct case
                End If
            End If
            Exit Do
        End If

        ' Attempt to create a reference.
        On Error Resume Next ' defer error handling
            Set nws = wb.Worksheets(nName)
        On Error GoTo ClearError ' enable error handling
        'On Error GoTo 0 ' disable error handling (usually, not to be used here)
        
        ' Rename.
        If nws Is Nothing Then
            sws.Name = nName
            Exit Do
        Else
            Set nws = Nothing
            nName = NewName & LeftDelimiter & nIndex & RightDelimiter
            nIndex = nIndex + 1
        End If
    Loop

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub

Answer 2

如果工作表的名称已经带有“_2”怎么办？如果是这种情况，您可能需要多加思考。

试试这个。我已经在自己的空间中对其进行了测试，但您可能需要稍微更改代码以使其适用于您的确切场景...

Sub renameWorksheet()
    
    Dim ws As Worksheet, lngSuffix As Long, strSuffix As String
    
    For Each ws In ThisWorkbook.Worksheets
    
        On Error Resume Next
        
        Err.Description = " "
        lngSuffix = 1
        
        While Err.Description <> ""
            Err.Clear
                    
            ws.Name = Range("O11").Value & "-" & Range("N11").Value
            
            If Err.Description <> "" Then
                strSuffix = "_" & lngSuffix
                lngSuffix = lngSuffix + 1
            End If
        Wend
    Next ws
    
End Sub