habe den Code noch etwas angepasst.
21.02.2010 12:36:42
Tino
Hallo,
die Tabellen werden erst nach Namen sortiert und danach nach der letzten Ziffer im Namen.
kommt als Code in Modul1
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
kommt als Code in Modul2
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
Gruß Tino