Sub Sortieren()
Dim x As Integer, i As Integer
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
For x = Worksheets.Count To 2 Step -1
If Mid(Worksheets(x).Name, 8, 3) * 1 Option Explicit
Sub Sortieren()
Dim x As Integer, i As Integer
Application.ScreenUpdating = False
Worksheets("Muster-Tabelle").Move After:=Worksheets(Worksheets.Count)
Worksheets("Alle-Tabellen").Move After:=Worksheets(Worksheets.Count)
For i = 1 To Worksheets.Count - 2
For x = Worksheets.Count - 2 To 2 Step -1
If Mid(Worksheets(x).Name, 8, 3) * 1 Sub Sortieren()
Dim x As Integer, i As Integer
On Error Resume Next
Application.ScreenUpdating = False
For i = 1 To Worksheets.Count
For x = Worksheets.Count To 2 Step -1
If Mid(Worksheets(x).Name, 8, 3) * 1 Worksheets("Muster-Tabelle").Move after:=Worksheets(Worksheets.Count)
Worksheets("Alle-Tabellen").Move after:=Worksheets(Worksheets.Count)
Application.ScreenUpdating = True
Worksheets("Tabelle1").Activate
End Sub
Option Explicit
Sub TabellenSort()
Dim meAr(), i As Integer
Redim meAr(Sheets.Count - 1, 1)
For i = 1 To Worksheets.Count
meAr(i - 1, 0) = Sheets(i).Name
meAr(i - 1, 1) = Ziffer(Sheets(i).Name)
Next i
QuickSort meAr, Lbound(meAr), Ubound(meAr), 1, False
For i = Ubound(meAr) To Lbound(meAr) Step -1
Worksheets(meAr(i, 0)).Move After:=Sheets(i + 1)
Next i
End Sub
Option Explicit
Function Ziffer(ByVal strText$) As Integer
Dim Regex As Object
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Pattern = "\D+\d{0,}\D+"
.Global = True
strText = .Replace(strText, "")
If IsNumeric(strText) Then
Ziffer = strText * 1
Else
Ziffer = 0
End If
End With
Set Regex = Nothing
End Function
Sub QuickSort(ByRef sArray, ByVal StartUnten As Long, ByVal EndeOben As Long, _
ByVal LCol As Long, Optional ByVal Absteigend As Boolean = False)
Dim iUnten As Long, iOben, iMitte, y
Dim A As Long
iUnten = StartUnten
iOben = EndeOben
iMitte = sArray((StartUnten + EndeOben) / 2, LCol)
While (iUnten <= iOben)
If Not Absteigend Then
While (sArray(iUnten, LCol) < iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte < sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
Else
While (sArray(iUnten, LCol) > iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte > sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten <= iOben) Then
For A = Lbound(sArray, 2) To Ubound(sArray, 2)
y = sArray(iUnten, A)
sArray(iUnten, A) = sArray(iOben, A)
sArray(iOben, A) = y
Next A
iUnten = iUnten + 1
iOben = iOben - 1
End If
Wend
If (StartUnten < iOben) Then Call QuickSort(sArray, StartUnten, iOben, LCol, Absteigend)
If (iUnten < EndeOben) Then Call QuickSort(sArray, iUnten, EndeOben, LCol, Absteigend)
End Sub
Option Explicit
Sub TabellenSort()
Dim meAr(), i As Integer
Redim meAr(Sheets.Count - 1, 1)
For i = 1 To Worksheets.Count
meAr(i - 1, 0) = Sheets(i).Name
meAr(i - 1, 1) = Ziffer(Sheets(i).Name)
Next i
QuickSort meAr, Lbound(meAr), Ubound(meAr), 0, True
QuickSort meAr, Lbound(meAr), Ubound(meAr), 1, False
For i = Ubound(meAr) To Lbound(meAr) Step -1
Worksheets(meAr(i, 0)).Move After:=Sheets(i + 1)
Next i
End Sub
Option Explicit
Function Ziffer(ByVal strText$) As Integer
Dim Regex As Object
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Pattern = "\w+[^\d]"
.Global = True
strText = .Replace(strText, "")
If IsNumeric(strText) Then
Ziffer = strText * 1
Else
Ziffer = 0
End If
End With
Set Regex = Nothing
End Function
Sub QuickSort(ByRef sArray, ByVal StartUnten As Long, ByVal EndeOben As Long, _
ByVal LCol As Long, Optional ByVal Absteigend As Boolean = False)
Dim iUnten As Long, iOben, iMitte, y
Dim A As Long
iUnten = StartUnten
iOben = EndeOben
iMitte = sArray((StartUnten + EndeOben) / 2, LCol)
While (iUnten <= iOben)
If Not Absteigend Then
While (sArray(iUnten, LCol) < iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte < sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
Else
While (sArray(iUnten, LCol) > iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte > sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten <= iOben) Then
For A = Lbound(sArray, 2) To Ubound(sArray, 2)
y = sArray(iUnten, A)
sArray(iUnten, A) = sArray(iOben, A)
sArray(iOben, A) = y
Next A
iUnten = iUnten + 1
iOben = iOben - 1
End If
Wend
If (StartUnten < iOben) Then Call QuickSort(sArray, StartUnten, iOben, LCol, Absteigend)
If (iUnten < EndeOben) Then Call QuickSort(sArray, iUnten, EndeOben, LCol, Absteigend)
End Sub