Renaming Sheets from cells with a loop - excel

Question

The code below is what i use to rename a bunch of sheets within a workbook. it works perfectly. It renames the sheet based off of a cell in that sheet. but now i have two sheets trying to use the same name. So i want to keep the same code but add a loop so if that happens, it will add a "2" to the second sheet. Ie cell contains "John Doe". Sheet will rename to "John Doe" and the next sheet that tries to use it will rename "John Doe 2"
Thank you
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

just to show another way you can reach your goal
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
it tries to set the name (and if that is not working it sets the name & 2 - 19 (if that doesnt work, it pops up a message box and exits the sub)

Answer 2

Use a controlled error to adjust the string containing the worksheet name until it find something it can use.
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
I have it set yo attempt a numerical suffix up to 9. It it reaches that, it reports the error and exits the sub. I would not recommend running this without an escape clause. If nothing else, you may run into an illegal character when parsing the string for the worksheet name.

Answer 3

Based on the link #Scott Craner provided in his comment, I am providing another solution that I believe is a bit more functional and cleaner and easier to read.
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

Jeeped beat me to it, but here is another possible adjustment you could make:
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