Question

下面的代码是我用来重命名工作簿中的一堆工作表。它完美地运作。它根据该工作表中的单元格重命名工作表。但现在我有两张试图使用相同的名字。所以我想保留相同的代码，但添加一个循环，所以如果发生这种情况，它将在第二张表中添加“2”。即单元格包含“John Doe”。工作表将重命名为“John Doe”，尝试使用它的下一个工作表将重命名为“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 。它到达那个，它报告错误并退出子。我不建议在没有escape子句的情况下运行它。如果不出意外，在解析工作表名称的字符串时可能会遇到非法字符。

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在评论中提供的链接，我提供了另一种解决方案，我相信它更具功能性，更清晰，更易于阅读。

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

它试图设置名称（如果它不起作用，它会设置名称＆amp; 2 - 19（如果它不起作用，它会弹出一个消息框并退出子名称）

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

4 个答案: