Option Explicit
Option Compare Text
' ****************************************************************
' Autor/en und Original-Quelltext unter:
' https://www.online-vba.de/vba_createsheets.php
' Verwendung der Quelltexte auf eigene Gefahr!
' Es gelten die Nutzungsbedingungen von https://www.online-vba.de
' ****************************************************************
' Verwendung: Markieren Sie einen Zellenbereich und starten Sie dieses Makro
Public Sub OVBAde_ArbeitsblaetterVonListeErstellen()
Dim oZelle As Object
Dim oNewSheet As Object
Dim lSuccessCounter As Long
Dim lErrCounter As Long
If Workbooks.Count < 1 Then Exit Sub
lErrCounter = 0
lSuccessCounter = 0
'Sicherheitsabfrage
If MsgBox("Sind Sie sicher, dass Sie " & Selection.Cells.Count & _
" neue und leere Arbeitsblätter erstellen wollen?", _
vbExclamation + vbYesNo, "HINWEIS!") = vbYes Then
On Error Resume Next
For Each oZelle In Selection.Cells
If Trim(CStr(oZelle.Value)) <> "" Then
Set oNewSheet = ActiveWorkbook.Sheets.Add(after:=Sheets(Sheets.Count))
oNewSheet.Name = Trim(CStr(oZelle.Value))
If Err.Number <> 0 Then
Err.Number = 0
Err.Clear
Application.DisplayAlerts = False
oNewSheet.Delete
Application.DisplayAlerts = True
lErrCounter = lErrCounter + 1
Else
lSuccessCounter = lSuccessCounter + 1
End If
End If
Next oZelle
On Error GoTo 0
If lErrCounter <> 0 Then
MsgBox lErrCounter & " Arbeitsblätter konnten nicht erstellt werden, " & _
"da Ihr Name entweder bereits vorhanden ist oder ungültige Zeichen enthält!" & _
vbCrLf & "Es wurden " & lSuccessCounter & " Arbeitsblätter erstellt.", _
vbInFormation + vbOKOnly, "WARNUNG!"
Else
MsgBox "Es wurden " & lSuccessCounter & " Arbeitsblätter erstellt.", _
vbInFormation + vbOKOnly, "HINWEIS!"
End If
End If
End Sub