Anbei der komplette Code für das Tabellenmodul, die Sortierung habe ich auskommentiert.
' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet, objNew As Worksheet, rng As Range
Dim strMsg As String
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
If Not Intersect(Target, Range("A6:A200")) Is Nothing Then
For Each objSh In ThisWorkbook.Worksheets
Select Case objSh.Name
Case "Auswertung Kalenderstudie", "Mustererhebungsblatt", "ABC", "AD vs Office", "B-Grund", "Basisdaten" 'Tabellen die nicht gelöscht werden sollen
Case Else
If IsError(Application.Match(objSh.Name, Me.Range("A6:A200"), 0)) Then objSh.Delete
End Select
Next
For Each rng In Intersect(Target, Me.Range("A6:A200"))
If rng <> "" Then
If IsValidSheetName(rng.Text) Then
If Not SheetExist(rng.Text) Then
Sheets("Mustererhebungsblatt").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = rng.Text
Me.Hyperlinks.Add Anchor:=rng, Address:="", SubAddress:="'" & rng.Text & "'!A1"
Else
If Application.CountIf(Me.Range("A6:A" & rng.Row), rng) > 1 Then
MsgBox "Der Name '" & rng.Text & "' ist schon vorhanden!"
rng = ""
End If
End If
Else
strMsg = strMsg & rng.Text & vbLf
End If
End If
Next
Me.Activate
sortSheets ThisWorkbook, , , 7 'ab dem 7. Blatt sortieren
'Me.Range("A6:A200").Sort Key1:=Me.Range("A6"), Order1:=xlAscending, Header:=xlNo
If Len(strMsg) Then
MsgBox "Ungültige Blattnamen!" & vbLf & vbLf & _
"Folgende Tabellen konnte nicht erstellt werden!" & vbLf & _
vbLf & strMsg, vbInformation, "Hinweis"
End If
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'Worksheet_Change'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Tabelle1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objSh = Nothing
Set objNew = Nothing
Set rng = Nothing
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 Sub sortSheets(WBook As Workbook, Optional Order As XlSortOrder = xlAscending, Optional AlphaNumeric As Boolean = True, Optional StartIndex As Long = 1)
Dim lngA As Integer, lngB As Integer
Dim objActive As Object
If StartIndex >= WBook.Sheets.Count Then Exit Sub
Set objActive = ActiveSheet
With WBook
For lngA = StartIndex To .Sheets.Count
For lngB = StartIndex To .Sheets.Count - 1
If Format(UCase$(.Sheets(lngB + IIf(Order = xlAscending, 0, 1)).Name), _
IIf(AlphaNumeric, String(32, "0"), "@")) > Format(UCase$(.Sheets(lngB + _
IIf(Order = xlAscending, 1, 0)).Name), IIf(AlphaNumeric, _
String(32, "0"), "@")) Then
.Sheets(lngB).Move After:=.Sheets(lngB + 1)
End If
Next
Next
End With
objActive.Activate
End Sub
