Renaming Sheets with loop function - vba

Question

I'm trying to rename all sheets and then put them in alphabetical order.
I'm getting the error Method 'Name' of object'_Worksheet' failed.
Any guidance is greatly appreciated
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$4,LEN($A$4)-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$4,LEN($A$4)-16)),"","","""")"
str = ws.Range("S4").Value
ws.Name = str
End If
Next ws
End Sub

Answer 2

I think the code could be like this. Note that there are restrictions for naming sheets and sheet names cannot be repeated. So I recommend using Debug.Print when debugging code (included in the code).
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