excel vba code error(subscript out of range) - excel

Question

Hi all I had a code in excel vba that makes me able to change sheet name according to cell value i right click on sheet name then select (view code ) then paste the code it worked well with the sheet i did a simple macro that copy the sheet content into another new sheet then paste the code that changes the sheet name with the cell value but i got an error i just need a macro that add new sheet and copy the current sheet content into the new and make the sheet name dependent on cell value (b3)
i have 0 experience in visual basic
here is some screenshots
thanks for helping me
this the sheet name code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3")) Is Nothing Then
ActiveSheet.Name = ActiveSheet.Range("B3")
End If
End Sub
i have already explained that THAT

Answer 1

Create a Copy of the Active Sheet
Copy this code into a standard module, e.g. Module1.
Option Explicit
Sub CopyActiveSheet()
' In the worst case scenario, you'll end up with an additional worksheet
' that could not be renamed. If you want to keep this worksheet,
' set DeleteIfCannotRename to False.
Const DeleteIfCannotRename As Boolean = True
' Invalidate the active sheet.
Dim sh As Object: Set sh = ActiveSheet
If sh Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf sh Is Worksheet Then Exit Sub ' not a worksheet
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = ActiveSheet
' Create a copy.
sws.Copy After:=sws
' Reference the copy.
Dim dws As Worksheet: Set dws = ActiveSheet
' Write the value form 'B3' to a variable.
Dim dName As String: dName = CStr(dws.Range("B3").Value)
Dim ErrNumber As Long
' Prevent error if a sheet with the same name already exists
' or the value in 'B3' doesn't contain a valid worksheet name.
On Error Resume Next ' turn on error-trapping
' Attempt to rename.
dws.Name = dName
ErrNumber = Err.Number ' store the error number in a variable
On Error GoTo 0 ' turn off error trapping
' Delete and inform. Out-comment or delete the 'MsgBox' line(s)
' if the message box is too annoying.
If DeleteIfCannotRename Then ' will delete
If ErrNumber <> 0 Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
MsgBox "Could not rename to '" & dName & "' so it got deleted.", _
vbCritical, "CopyActivesheet"
End If
Else ' will not delete
MsgBox "Could not rename to '" & dName & "'.", _
vbCritical, "CopyActivesheet"
End If
End Sub