Hallo Face,

Der Code dazu könnte z.B. so aussehen. Den Namensbereich musst du noch anpassen. 

Sub BlattKopieren()

  Set Namen = Sheets("Tabelle1").Range("B2:B16")
  
  For i = 1 To Sheets("Tabelle1").Range("F9")
    Sheets("Tabelle2").Copy After:=Sheets(Sheets.Count)
    n = Namen.Cells(i)
    
    Do
      If n = "" Then
        n = InputBox("Es ist noch kein Name angegeben. Bitte geben Sie einen Namen ein", , _
        Sheets(Sheets.Count).Name)
      End If
      If Len(n) > 31 Then
        n = InputBox("Der Name " & n & " ist länger als 31 Zeichen, " _
        & "Bitte geben Sie einen kürzeren Namen ein.", , Left(n, 31))
      End If
      If IsIn(n, "\", "/", "?", "*", "[", "]") Then
        n = InputBox("Der Name " & n & " enthält mindestens eines der verbotenen Zeichen: " _
        & "\, /, ?, *, [, ] " & Chr(13) & "Neuer Name ist", , ReplaceN(n))
      End If
      If SheetExists(n) Then
        n = InputBox("Ein Blatt mit dem Namen " & n & " existiert schon. " _
        & "Geben Sie einen anderen Namen ein.")
      End If
    Loop Until n <> "" And Len(n) <= 31 And Not IsIn(n, "\", "/", "?", "*", "[", "]") And Not SheetExists(n)
    Sheets(Sheets.Count).Name = n
  Next i
  
End Sub
Private Function IsIn(ByVal s As String, ParamArray CompareStrings()) As Boolean
  For Each c In CompareStrings
    If InStr(1, s, c) > 0 Then IsIn = True
  Next c
End Function

Private Function ReplaceN(ByVal n As String) As String
  n = Replace(n, "\", "")
  n = Replace(n, "/", "")
  n = Replace(n, "?", "")
  n = Replace(n, "*", "")
  n = Replace(n, "[", "")
  n = Replace(n, "]", "")
  ReplaceN = n
End Function
Private Function SheetExists(ByVal s As String) As Boolean
  On Error Resume Next
  SheetExists = Sheets(s).Name <> "" And Not Sheets(Sheets.Count).Name = s
End Function

Gruß Mr. K.