使用循环从单元格重命名工作表

Question

下面的代码是我用来重命名工作簿中的一堆 sheet 的代码。它工作得很好。它根据 sheet 中的一个单元格重命名 sheet。但现在我有两个 sheet 试图使用相同的名称。所以我想保留相同的代码但添加一个循环，这样如果发生这种情况，它将向第二个 sheet 添加一个“2”。即单元格包含"John Doe"。 Sheet 将重命名为 "John Doe"，下一个尝试使用它的 sheet 将重命名为 "John Doe 2"

谢谢

Sub RenameLaborLog()
    Dim rs As Worksheet
    For Each rs In Sheets
        rs.Name = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."

    Next rs
End Sub

Answer 1

使用受控错误来调整包含工作表名称的字符串，直到找到可以使用的内容。

Sub RenameLaborLog()
    Dim rs As Worksheet, snam As String, idupe As Long

    On Error GoTo bm_Dupe_WS_Name

    For Each rs In Sheets
        idupe = 1
        snam = Split(rs.Range("H4").Value, " ")(1) & ", " & _
               Left(Split(rs.Range("H4").Value)(0), 1) & "."
        rs.Name = snam
    Next rs

bm_Dupe_WS_Name:

    If idupe > 8 Then
        Debug.Print Err.Number & ": " & snam & " - " & Err.Description
        Exit Sub
    ElseIf Right(snam, 1) = CStr(idupe) Then
        snam = Trim(Left(snam, Len(snam) - 1))
    End If
    idupe = idupe + 1
    snam = snam & Chr(32) & idupe
    Resume
End Sub

我已将其设置为您尝试输入最大为 9 的数字后缀。它到达那个，它报告错误并退出子。如果没有免责条款，我不会推荐运行ning 这个。如果不出意外，在解析工作表名称的字符串时，您可能运行变成了非法字符。

Answer 2

Jeeped 先于我，但您可以进行另一种可能的调整：

Sub RenameLaborLog()

    Dim rs As Worksheet, wsName As String, wsCheck As Worksheet, i As Integer

    For Each rs In Sheets
        ' Get the sheet name
        wsName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
        ' Check if it exists
        Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName: On Error GoTo 0
        ' Check if multiples already exist
        While Not wsCheck Is Nothing
            ' If even one exits, "i" will be iterated
            i = i + 1
            Set wsCheck = Nothing: On Error Resume Next: Set wsCheck = wsName & "_" & i: On Error GoTo 0
        Wend
        ' If at least one name already existed, name it with the current iteration.
        If Not i = 0 Then wsName = wsName & "_" & i
        rs.Name = wsName
    Next rs
    Set rs = Nothing: Set wsCheck = Nothing

End Sub

Answer 3

根据@Scott Craner 在其评论中提供的 link，我提供了另一种解决方案，我认为它更实用、更简洁、更易于阅读。

Sub RenameLaborLog()

    Dim rs As Worksheet, sName As String
    For Each rs In Sheets

        sName = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."

        i = 1

        Do

            If Not WorksheetExist(sName) Then
                rs.Name = sName
                Exit Do
            Else: sName = sName & "_" & i + 1
            End If

        Loop

    Next rs

End Sub

Function WorksheetExist(sName As String, Optional wb As Workbook) As Boolean

Dim wbCheck As Workbook, ws As Worksheet
If wb Is Nothing Then Set wbCheck = ThisWorkbook Else: Set wbCheck = wb

WorksheetExist = False

For Each ws In wbCheck.Worksheets
    If ws.Name = sName Then
        WorksheetExist = True
        Exit For
    End If
Next

End Function

Answer 4

只是为了展示实现目标的另一种方式

Sub RenameLaborLog()
  Dim rs As Worksheet, i As Long, str As String
  On Error Resume Next
  For Each rs In Sheets
    str = Split(rs.Range("H4").Value, " ")(1) & ", " & Left(Split(rs.Range("H4").Value)(0), 1) & "."
    rs.Name = str
    i = 1
    While Err.Number <> 0 And i < 20
      Err.Clear: i = i + 1
      rs.Name = str & i
    Wend
    If Err.Number <> 0 Then MsgBox "Error: " & rs.Name & " cant be set to any " & str: Exit Sub
  Next rs
End Sub

它尝试设置名称（如果不起作用，它会设置名称 & 2 - 19（如果不起作用，它会弹出一个消息框并退出子程序）

使用循环从单元格重命名工作表

Renaming Sheets from cells with a loop

excel

vba

cell