Rename sheet with (2) after existing name of existing sheet

[al]

Sub SheetNameActivecell()

Application.ActiveSheet.Name = Left(Application.Substitute
(ActiveCell.Value, "/", ""), 31)

End Sub

Would also like to improve macro by adding codes which would allow to
name a sheet with (2) at end of an existing sheet name.
e.g if "Google" already exist - macro would rename sheet as "Google
(2)"

Thxs

 

[Rick Rothstein]

Using my response to your previous question as a basis (since I assume you
still want to replace all the bad characters and not just the slash), here
is a new function (I changed the name slightly) modified to do this
additional request...

Function FixName(ProposedName As String) As String
Dim V As Variant, WS As Worksheet, Counter As Long
FixName = ProposedName
For Each V In Array("\", "/", "?", "*", "[", "]")
FixName = Replace(FixName, V, "")
Next
FixName = Left(FixName, 31)
For Each WS In Worksheets
If InStr(1, WS.Name, FixName, vbTextCompare) Then Counter = Counter + 1
Next
If Counter Then FixName = FixName & "(" & (Counter + 1) & ")"
End Function

What this function will do is add (2) if the name already exists and add (3)
if the name and the (2) version of the name both exist and so on. You would
install the function the same way I gave you in my other post, namely, put
it into a Module... click Insert/Module from the VB menu bar. Then, all you
have to do in your code is this...

ActiveSheet.Name = FixName(ActiveCell.Value)

 

[al]

Using my response to your previous question as a basis (since I assume you
still want to replace all the bad characters and not just the slash), here
is a new function (I changed the name slightly) modified to do this
additional request...

Function FixName(ProposedName As String) As String
Dim V As Variant, WS As Worksheet, Counter As Long
FixName = ProposedName
For Each V In Array("\", "/", "?", "*", "[", "]")
FixName = Replace(FixName, V, "")
Next
FixName = Left(FixName, 31)
For Each WS In Worksheets
If InStr(1, WS.Name, FixName, vbTextCompare) Then Counter = Counter + 1
Next
If Counter Then FixName = FixName & "(" & (Counter + 1) & ")"
End Function

What this function will do is add (2) if the name already exists and add (3)
if the name and the (2) version of the name both exist and so on. You would
install the function the same way I gave you in my other post, namely, put
it into a Module... click Insert/Module from the VB menu bar. Then, all you
have to do in your code is this...

ActiveSheet.Name = FixName(ActiveCell.Value)

--
Rick (MVP - Excel)

Sub SheetNameActivecell()

Application.ActiveSheet.Name = Left(Application.Substitute
(ActiveCell.Value, "/", ""), 31)

End Sub

Would also like to improve macro by adding codes which would allow to
name a sheet with (2) at end of an existing sheet name.
e.g if "Google" already exist - macro would rename sheet as "Google
(2)"

Thxs

Thxs very much ! Just what i need

 

[Chip Pearson]

Try code like

Sub AAA()
Dim S As String
On Error Resume Next
S = ThisWorkbook.Worksheets(ActiveCell.Text).Name
If Err.Number = 0 Then
S = ActiveCell.Text & " (2)"
Else
S = ActiveCell.Text
End If
ActiveSheet.Name = Left(Replace(S, "/", vbNullString), 31)
End Sub

This will get rid of the "/" character and add "(2)" to the sheet name
if a sheet with the name in the active cell already exists. However,
if it is possible that the active cell may contain text that already
has a "(2)" suffix (e.g., activecell.text = "Google (2)"), the code
will rename the sheet "Google (2) (2)". If you want the sheet to be
renamed "Google (3)" instead, use the code below:


Sub AAA()
Dim S As String
Dim WS As Worksheet
Dim N As Long
Dim M As Long

S = Replace(ActiveCell.Text, "/", vbNullString)

On Error Resume Next
Set WS = ThisWorkbook.Worksheets(S)
If Err.Number = 0 Then
N = 1
Do Until False
N = N + 1
M = InStrRev(S, " (")
If M > 0 Then
S = Left(S, M - 1) & " (" & CStr(N) & ")"
Else
S = S & " (" & CStr(N) & ")"
End If
Set WS = ThisWorkbook.Worksheets(S)
If Err.Number <> 0 Then
ActiveSheet.Name = S
Exit Do
End If
Loop
Else
ActiveSheet.Name = S
End If
End Sub

Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]