Hallo Gregor,
der Code bezieht sich auf ds aktive Tabellenblatt.
' **********************************************************************
' Modul: Modul11 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub blattAnlegen()
Dim vntList As Variant, lngLast As Long, lngIndex As Long
On Error GoTo ErrExit
Application.ScreenUpdating = False
With ActiveSheet
lngLast = Application.Max(2, .Cells(.Rows.Count, 4).End(xlUp).Row)
vntList = UniqueList(.Range("D2:D" & lngLast))
For lngIndex = LBound(vntList) To UBound(vntList)
If IsValidSheetName(vntList(lngIndex)) Then
If Not SheetExist(vntList(lngIndex)) Then
ThisWorkbook.Worksheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = vntList(lngIndex)
End If
End If
Next
.Activate
End With
ErrExit:
Application.ScreenUpdating = True
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object
Set objRegExp = CreateObject("vbscript.regexp")
With objRegExp
.Global = True
.Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
.IgnoreCase = True
IsValidSheetName = .test(strName)
End With
Set objRegExp = Nothing
End Function
Private Function UniqueList(Matrix As Range, Optional IncludeNull As Boolean = True, Optional Sorted As Boolean = True) As Variant
Dim objDic As Object, rng As Range, varTmp() As Variant, vntExclude As Variant
vntExclude = IIf(IncludeNull, "", 0)
Set objDic = CreateObject("Scripting.Dictionary")
For Each rng In Matrix
If rng.Value <> vntExclude Then objDic(rng.Value) = 0
Next
varTmp = objDic.keys
If Sorted Then QuickSort varTmp
UniqueList = varTmp
Set objDic = Nothing
End Function
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant
UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)
P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)
Do
Do While (data(P1) < T1)
P1 = P1 + 1
Loop
Do While (data(P2) > T1)
P2 = P2 - 1
Loop
If P1 <= P2 Then
T2 = data(P1)
data(P1) = data(P2)
data(P2) = T2
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG
End Sub