avoid error of duplicate sheet when renaming sheet with cell contents

jiddings

Board Regular
Joined
Nov 22, 2008
Messages
135
I have, on a weekly basis, a workbook having 60+ worksheets with each sheet named page1, page2, etc.
I am renaming each sheet with the following code based on the contents of cell C5 in each sheet. The contents of cell C5 is a user name which should not be duplicated or changed on the worksheet name.
At times, the weekly workbook download contains another sheet with the same username in cell C5 and the code errors when attempting to rename a sheet with a sheet name that already exists.

Is there VBA code that can check in advance, each worksheet, for a duplicate username in cell C5 to warn the user there is a duplicate username in the sheets before running the following code?

Thanks

Code:
Sub RenameSheets()'/////////////////////////////////////
' Renames each sheet based on cell "C5"
'/////////////////////////////////////
    Dim Wks         As Worksheet
    For Each Wks In ThisWorkbook.Worksheets
      If Wks.Name <> "Combined" And Wks.Name <> "employees" Then
       Wks.Activate
     ActiveSheet.Name = ActiveSheet.Range("C5").Value 
    End If
    Next Wks
    
End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Code:
Sub RenameSheets()
Dim Wks As Worksheet
For Each Wks In ThisWorkbook.Worksheets
    With Wks
    If .Name <> "Combined" And .Name <> "employees" And .Name <> .[C5] Then
        If Evaluate("IsError(" & .[C5] & "!1:1)") Then .Name = .[C5] _
        Else: MsgBox "Cannot rename sheet " & .Name & " to " & .[C5] _
        & Chr(13) & "There is already a sheet with the name " & .[C5]
    End If
    End With
Next Wks
End Sub
 
Upvote 0
footoo,
Thanks for your response and your code does work. However, I have this VBA code as part of a larger VBA application and implementing it in this way stops the entire code in the middle.
My thoughts were to run some code that would warn the user of duplicate usernames in cell C5 on another sheets in advance prior to the start of renaming the sheets.
I have been working on the following code to check for duplicates on the 60+ worksheets and I have thoughts of placing the "found info" into an array and displaying the array info. in a message box for the user. But I don't have any experience with arrays and their use for this situation.

Code:
Sub find_duplicates()
    Dim Wks As Worksheet
    Dim Wks1 As Worksheet
    For Each Wks In ThisWorkbook.Worksheets
           Wks.Activate
           myworksheet = Wks.Name
           myvalue = ActiveSheet.Range("C5").Value
'            Debug.Print myvalue
                For Each Wks1 In ThisWorkbook.Worksheets
                If Wks1.Name <> myworksheet Then
                Wks1.Activate
                myvalue1 = ActiveSheet.Range("C5").Value
                    If myvalue = myvalue1 Then
                    Debug.Print myvalue
                    Debug.Print Wks.Name
                    Debug.Print Wks1.Name
                    End If
                 End If
                Next Wks1
        Next Wks
Debug.Print "end of macro"
End Sub

The immediate window output for the above code with one duplicate username (two sheets) is as follows:
dbeans <--- username
Page 9 <--- sheet name prior to rename to username
Page 10
dbeans
Page 10
Page 9
end of macro

and takes approximately 19 seconds to run.
I would greatly appreciate any input on how I can speed up the code and add placing the "found info" into an array followed by displaying the array info. in a message box for the user.
 
Upvote 0
The following will produce a msgbox showing the user name and the sheet name where there is already an existing sheet with that user name.
Code:
Sub CheckDupNames()
Dim Wks As Worksheet, txt$
For Each Wks In ThisWorkbook.Worksheets
    With Wks
        If .Name <> .[C5] And Not Evaluate("IsError(" & .[C5] & "!1:1)") Then _
            txt = txt & Chr(13) & .[C5] & " - " & .Name
    End With
Next
If txt = "" Then
    MsgBox "There are no duplicates."
Else
    MsgBox txt
End If
End Sub
 
Last edited:
Upvote 0
footoo,
Thanks for your addtional VBA sub.
It is not working as I intended and it does not find duplicate usernames in cell C5 on two worksheets. For this case, the same user name exists in cell C5 on worksheet Page 9 and same username in cell C5 on worksheet Page 10. Your 8:10 PM code posting does not report the same username existing on sheet Page 9 and sheet Page 10.

I may not have provided a clear explanation of my workbook / worksheet configuration.
The workbook has 60+ worksheets. Each worksheet is named Page 1, Page 2, Page 3, Page 4, etc. through Page 60. Each worksheet contains a username in cell C5, which is intended to be unique. However, at times, the downloaded worksheet (the one at issue) contains two or more worksheets with the same username in cell C5 on separately named sheets (named Page 1, Page 2, Page 3, Page 4, etc. through Page 60). My goal is to rename all the sheets with the username in cell C5. As known, Excel will not permit the same sheet name in a workbook.

With that said, I'm attempting to determine, via VBA, if a duplicate username in cell C5 among all the worksheets and to report to the user in advance of processing the renaming sub code. My posting of that code reflects that incomplete attempt at my goal.
 
Upvote 0
The following adds a sheet which lists the user name duplicates :

Code:
Sub DuplicatedUserNames()
Dim Wks As Worksheet, lr%, rng As Range, x%
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Duplicates").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Duplicates"
[A1] = "User Name"
[B1] = "Sheet Name"
For Each Wks In ThisWorkbook.Worksheets
    If Wks.Name <> "Combined" And Wks.Name <> "employees" And Wks.Name <> "Duplicates" Then
        With Cells(Rows.Count, 1).End(xlUp)(2)
            .Value = Wks.[C5]
            .Offset(0, 1) = Wks.Name
        End With
    End If
Next
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A2:A" & lr)
For x = lr To 2 Step -1
    If WorksheetFunction.CountIf(rng, Cells(x, 1)) = 1 Then Rows(x).Delete
Next
[A:B].EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
 
Upvote 0
footoo,
Thank you for your VBA code!
I'm using it with a message box to alert the user of duplicates in worksheets.
I like your technique of:"WorksheetFunction.CountIf(rng, Cells(x, 1)) = 1 Then Rows(x).Delete" to show only duplicates.

You used "With Cells(Rows.Count, 1).End(xlUp)(2)". What does parentheses 2 parentheses accomplish?
Thanks again...
 
Upvote 0
You used "With Cells(Rows.Count, 1).End(xlUp)(2)". What does parentheses 2 parentheses accomplish?

It is the same as writing:
"With Cells(Rows.Count, 1).End(xlUp).Item(2,1)"
or
"With Cells(Rows.Count, 1).End(xlUp).Offset(1,0)"
 
Upvote 0

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top