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