Insert Sheet via cell value

[excelledsoftware]

Ok here we go. I put in some additional checks since worksheet names can not be over 31 characters or contain certain special characters. Please ensure that you 100% back up your work on all open excel workbooks when running this. It will delete all worksheets that are not in the range and it will not give a prompt before doing this.

Same instructions as above. Let me know if you have any questions.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim RangePass As Boolean
  If Target.Count > 1 Then
    CreateNewWorksheet ("")
    Exit Sub
  End If
  If Target.Row > 4 And Target.Row < 51 Then
    If Target.Column = 4 And Target.Value <> "" Then CreateNewWorksheet (Target.Value)
  End If
  
End Sub
Sub CreateNewWorksheet(UseValue As String)
  Dim wb As Workbook, nws As Worksheet, NewName As String
  Dim ws As Worksheet, cws As Worksheet, CheckString As String
  Dim CheckRow As Integer, CheckName As String, BadData As Variant
  Dim TempString As String, v As Variant
  
  Set wb = ThisWorkbook
  Set cws = wb.ActiveSheet
  BadData = Array("*", "[", "]", "/", "\", "?", "'", ":")
  'Add range names to a string to check
  CheckString = ""
  For CheckRow = 5 To 50
    TempString = Range("D" & CheckRow).Value
    For Each v In BadData
      TempString = Replace(TempString, v, "")
    Next v
    CheckString = CheckString & "[" & TempString & "]"
  Next CheckRow
  CheckString = "[" & cws.Name & "]" & CheckString
  'Delete not found worksheets
  For Each ws In wb.Worksheets
    CheckName = "[" & ws.Name & "]"
    Application.DisplayAlerts = False
    If InStr(1, CheckString, CheckName) = 0 Then
      ws.Delete
    End If
  Next ws
  Application.DisplayAlerts = True
  NewName = UseValue
  'Clear special characters
  For Each v In BadData
    NewName = Replace(NewName, v, "")
  Next v
  If NewName = "" Then End
  If Len(NewName) > 31 Then
    MsgBox "Name too long. no worksheet added."
    End
  End If
  

  If wb.Worksheets.Count > 49 Then
    MsgBox "This workbook can only contain 50 worksheets."
    'If you dont want the messagebox to come up just comment it out with a '
    End
  End If
  For Each ws In wb.Worksheets
    If ws.Name = NewName Then
      MsgBox ("The name " & NewName & " is already in use. No new worksheet added.")
      'You can comment out the message box if you just want code to end.
      End
    End If
  Next ws

  'All passed add the new worksheet
  Set nws = wb.Worksheets.Add(After:=cws)
  nws.Name = NewName
  cws.Activate  'Use a ' right before this line to select the new worksheet.
 
End Sub

Thanks