Need help to add sheet, rename and update in TOC

[patel]

it's no reccomended to attach e-mail address, spam risk, please delete

Sub AddSheet()
Dim ID
ID = Application.InputBox("Please enter the Patient Number.")
NewNames = "Patient No - " & ID
If Not WorksheetExists(NewNames) Then
  Application.ScreenUpdating = False
  With Sheets("Main_1")
    .Visible = True
    .Copy After:=ActiveSheet
    .Visible = False
  End With
  ActiveSheet.Name = NewNames
  Call Create_TOC
  Application.ScreenUpdating = True
Else
  MsgBox " Sheets exists"
End If
End Sub
Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
    On Error Resume Next
    WorksheetExists = (Sheets(WorksheetName).Name <> "")
    On Error GoTo 0
End Function