使用循环功能重命名工作表

Question

我正在尝试重命名所有工作表，然后将它们按字母顺序排列。我收到错误消息 Method 'Name' of object'_Worksheet' failed。非常感谢任何指导

Sub Rename()
    Dim ws As Worksheet, str As String
    
    For Each ws In ActiveWorkbook.Worksheets

        If ws.Name <> "Summary" Then
            Range("S4").Select
            ActiveCell.Formula = "=SUBSTITUTE(TRIM(RIGHT($A,LEN($A)-16)),"","","""")"
            str = ws.Range("S4").Value
            ws.Name = str
            
        End If
        
    Next ws
End Sub

Answer 1

Sub Rename()
    Dim ws As Worksheet, str As String
    
    For Each ws In ActiveWorkbook.Worksheets

        If ws.Name <> "Summary" Then
            ws.Range("S4") = "=SUBSTITUTE(TRIM(RIGHT($A,LEN($A)-16)),"","","""")"
            str = ws.Range("S4").Value
            ws.Name = str
        End If
        
    Next ws
End Sub

Answer 2

我认为代码可以是这样的。请注意，there are restrictions for naming sheets 和 sheet 名称不能重复。所以我推荐在调试代码的时候使用Debug.Print（包含在代码中）

Option Explicit

Sub Rename()
    Dim ws As Worksheet, txt As String, a As Variant, i As Long, j As Long
    
    ReDim a(1 To ActiveWorkbook.Worksheets.Count) As String
    i = 0
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Summary" Then
            txt = ws.Range("A4").Text
            txt = Replace(Trim(Right(txt, Len(txt) - 16)), ",", "") 'we don't know what is in A4, so you need to tweak it
            Debug.Print "Trying to rename sheet '" & ws.Name & "' to '" & txt & "'..."
            On Error Resume Next
            ws.Name = txt
            If Err.Number <> 0 Then
                Debug.Print vbTab & "FAILED to rename the sheet '" & ws.Name & "' to '" & txt & "'"
            Else
                i = i + 1
                a(i) = txt
            End If
            On Error GoTo 0
        End If
    Next ws
    
    If i > 0 Then
        ReDim Preserve a(1 To i)
        
        ' bubble sort sheets names
        For i = LBound(a) To UBound(a)
            For j = LBound(a) To UBound(a)
                If a(i) < a(j) Then
                    txt = a(i): a(i) = a(j): a(j) = txt
                End If
            Next j
        Next i
        
        ' rearrange the sheets
        For i = UBound(a) To LBound(a) Step -1
            ActiveWorkbook.Worksheets(a(i)).Move Before:=ActiveWorkbook.Worksheets(1)
        Next i
    Else
        MsgBox "No sheets renamed", vbCritical
    End If
End Sub

使用循环功能重命名工作表

Renaming Sheets with loop function

vba

loops

rename