Copy worksheet using VBA

[rbergeron]

I am trying to copy an existing worksheet using VBA. I am able to do this however I would like to add validation within the code that first checks if the worksheet name already exists and if it does show a MsgBox stating the worksheet already exists then loops until a valid name is entered.

Any help would be greatly appreciated.

[Yogi Anand]

Hi rbergeron:

Welcome to the Board!

Do you want to copy a Workbook or a Worksheet? It appears that you have done some work on this already -- how about posting your code for what you have so far, and then indicate where do you want to go from there.

[phantom1975]

Is this what you are looking for?

Sub Copy_Sheet()
Dim NewName As String
Dim Sh As Worksheet
****NewName = ActiveSheet.Name
DuplicateSearch:
****For Each Sh In Workbooks("Book2.xls").Worksheets
********If UCase(Sh.Name) = UCase(NewName) Then
************NewName = InputBox(NewName & " already exists.**Please enter a new name.", "Enter New Name")
************GoTo DuplicateSearch
********End If
****Next Sh
****ActiveSheet.Copy Workbooks("Book2.xls").Worksheets(1)
****ActiveSheet.Name = NewName
End Sub

[Tom Urtis]

Phantom:

Your code will error if the Cancel button is clicked, or OK is clicked with an empty input string, or if an illegal naming character is attempted.

This macro might cover most of the bases, long-winded as it is. Modify for the Sheet1 name being used as an example for the sheet you want to copy.

Sub AddSheetz()

'First, jump through the validation hoops
Dim AddSheetQuestion As Variant

'Define the application input box question
showAddSheetQuestion:
AddSheetQuestion = Application.InputBox("Please enter the name of the sheet you want to add," & vbCrLf & _
"or click the Cancel button to cancel the addition:", _
"What sheet do you want to add?")

'Cancel or the X was clicked
If AddSheetQuestion = False Then
MsgBox "You clicked the Cancel button." & vbCrLf & "No new sheet will be added.", 64, "Cancel was clicked."
Exit Sub

'OK was clicked without anything being entered
ElseIf AddSheetQuestion = "" Then
MsgBox "You clicked OK but entered nothing." & vbCrLf & vbCrLf & _
"Please type in a valid sheet name." & vbCrLf & "Otherwise, you must click Cancel to exit." & vbCrLf & vbCrLf & _
"Click OK and let's try again.", 48, "Hmmm...that didn't make sense..."
GoTo showAddSheetQuestion

End If

'See if a worksheet exists that is named as the new name being attempted to add.
'We want this code to error, because if it does, it will mean no such sheet exists
'so we can complete this macro.
On Error Resume Next
Worksheets(UCase(AddSheetQuestion)).Activate
If Err.number <> 9 Then
Err.Clear
MsgBox "A worksheet already exists that is named " & AddSheetQuestion & "." & vbCrLf & vbCrLf & _
"Please click OK, verify the name you really" & vbCrLf & _
"want to add, and try again." & vbCrLf & vbCrLf & "Sheet addition cancelled.", 48, "Sorry, that name already taken."
GoTo showAddSheetQuestion
Exit Sub
End If

'Error trap #2 for naming syntax error
On Error GoTo ErrorHandler1

'Here's the actual sheet addition code
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'Add and name the new sheet
Worksheets.Add
With ActiveSheet
.Name = AddSheetQuestion
.Move After:=Worksheets(Worksheets.count)
End With

'Make the Template sheet visible, and copy it
With Worksheets("Sheet1")
.Visible = xlSheetVisible
.Activate
End With
Cells.Copy
'Re-activate the new worksheet, and paste
Worksheets(AddSheetQuestion).Activate
Cells.Select
ActiveSheet.Paste
With Application
.CutCopyMode = False
.Goto Range("A1"), True
End With

With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With

'Inform the user the macro is completed
MsgBox "The new sheet name ''" & AddSheetQuestion & "'' has been added.", 64, "Sheet addition successful."
Exit Sub

'If a sheet naming syntax occurs:
ErrorHandler1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "You entered a character that cannot be part of a sheet name." & vbCrLf & _
"Sheet names cannot contain '':'', ''/'', ''\'', ''?'', ''*'', ''['', or '']''.", 16, "Name syntax error."
GoTo showAddSheetQuestion
Exit Sub
End Sub

[phantom1975]

I'll admit I sorta cranked out a solution without adding any error handling. I thought that I should have used Application.Inputbox, but had already posted it and didn't bother editing. The illegal characters escaped me completely though. Thanks for picking it up.

[Tom Urtis]

I want to follow up on this thread to thank Richie (UK) for PMing me this morning, telling me he received an error when he tested my code in a certain input sequence. Here's what he wrote to me, and then how he modified the code to handle that error:

In the code as posted try the following sequence of events:
1. On the first pass enter an invalid filename (I used /).
2. Then on the second pass enter a normal name (I used bob).
This through an error on the line "Worksheets(UCase(AddSheetQuestion)).Activate" - (Error 9). Something to do with the double error-checking I suspect but I couldn't quite pin it down. I revised the checking for an existing sheetname to a function approach and it now seems to work OK (see below).


Sub AddSheetz()

'First, jump through the validation hoops (need Variant to error-check)
Dim AddSheetQuestion As Variant

'Define the application input box question
showAddSheetQuestion:
AddSheetQuestion = Application.InputBox _
("Please enter the name of the sheet you want to add," & vbCrLf & _
"or click the Cancel button to cancel the addition:", _
"What sheet do you want to add?")

'Cancel or the X was clicked
If AddSheetQuestion = False Then
MsgBox "You clicked the Cancel button." & vbCrLf & _
"No new sheet will be added.", 64, "Cancel was clicked."
Exit Sub

'OK was clicked without anything being entered
ElseIf AddSheetQuestion = "" Then
MsgBox "You clicked OK but entered nothing." & vbCrLf & vbCrLf & _
"Please type in a valid sheet name." & vbCrLf & _
"Otherwise, you must click Cancel to exit." & vbCrLf & vbCrLf & _
"Click OK and let's try again.", 48, "Hmmm...that didn't make sense..."
GoTo showAddSheetQuestion

End If

'See if a worksheet exists that is named as the new name being attempted to add.
If SheetExists(CStr(AddSheetQuestion)) Then
MsgBox "A worksheet already exists that is named " & AddSheetQuestion & "." _
& vbCrLf & vbCrLf & _
"Please click OK, verify the name you really" & vbCrLf & _
"want to add, and try again." & vbCrLf & vbCrLf & "Sheet addition cancelled.", _
48, "Sorry, that name already taken."
GoTo showAddSheetQuestion
End If

'Error trap for naming syntax error
On Error GoTo ErrorHandler1

'Here's the actual sheet addition code
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With

'Add and name the new sheet
Worksheets.Add
With ActiveSheet
.Name = AddSheetQuestion
.Move After:=Worksheets(Worksheets.Count)
End With

'Make the Template sheet visible, and copy it
Worksheets("Sheet1").Cells.Copy

'Re-activate the new worksheet, and paste
Worksheets(AddSheetQuestion).Paste

With Application
.CutCopyMode = False
.Goto Range("A1"), True
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With

'Inform the user the macro is completed
MsgBox "The new sheet name ''" & AddSheetQuestion & "'' has been added.", _
64, "Sheet addition successful."

Exit Sub
'If a sheet naming syntax occurs:
ErrorHandler1:
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
MsgBox "You entered a character that cannot be part of a sheet name." & vbNewLine & _
"Sheet names cannot contain the following:-" & vbNewLine & _
"'':'' , ''/'' , ''\'' , ''?'' , ''*'' , ''['' , or '']''.", _
16, "Name syntax error."
On Error GoTo 0
GoTo showAddSheetQuestion

End Sub

Function SheetExists(strWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(strWSName)
If Not ws Is Nothing Then SheetExists = True
'Boolean function assumed to be False unless set to True
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''

If anyone gets other errors please post what you did to get them. Thanks again Richie for seeing that error.