Code optimieren?

Sub sort_sheets() Dim ws As Worksheet Dim wb As Workbook Dim counter As Integer Dim sheetArray Dim i, j i = 1: j = 1 Set wb = ThisWorkbook Set sheetArray = CreateObject("System.Collections.arraylist") For Each ws In wb.Sheets sheetArray.Add ws.name Next ws sheetArray.Sort counter = ThisWorkbook.Sheets.Count Do Set ws = ThisWorkbook.Sheets(i) If ws.name sheetArray(i - 1) Then Do Until j > counter Or ws.name = sheetArray(j - 1) j = j + 1 Loop Worksheets(i).Move Before:=Worksheets(j) End If j = 1 i = i + 1 Loop Until i > counter sheetArray.Clear Set ws = Nothing Set wb = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub sort_sheets2() Dim ws As Worksheet Dim wb As Workbook Dim sheetArray Dim i As Long Set wb = ThisWorkbook Set sheetArray = CreateObject("System.Collections.arraylist") '--- Blattnamen in Liste For Each ws In wb.Sheets sheetArray.Add ws.Name Next ws '--- Liste sortieren sheetArray.Sort '--- Blätter in Reihenfolge der Liste bringen For i = sheetArray.Count To 1 Step -1 wb.Sheets(sheetArray(i - 1)).Move before:=wb.Sheets(1) Next '--- Sonderpositionen für Doku und Übersicht wb.Sheets("Übersicht").Move before:=wb.Sheets(1) wb.Sheets("Doku").Move before:=wb.Sheets(1) End Sub

Hallo Leute,
mir ist gestern Abend noch aufgefallen, dass der Code oben falsch sortiert.
Wenn in der ArrayList zweistellige Zahlen sind, dann Prüft er bei .Sort nur auf die erste Stelle und
Sortiert deshalb die Tabellen falsch...
Hier ist ein QuickSort Code mit dem es funktioniert.
Die Subs spur_String_out und spur_String_in, sind für alle, deren Tabellennamen nur aus Zahlen bestehen, unwichtig.
(Sie entfernen den gewünschten String und speichern nur noch die Zahl im Array, nach Sortierung
wird der String dann wieder eingefügt)
ich habe das ganze auf die schnelle jetzt geschrieben, deshalb ist der Code etwas wirr, tut mir leid
Hier Code:

Option Explicit
Private sheetArray() As Variant
Sub Main_Sheetsort()
Dim i
Dim wb As Workbook
Set wb = ThisWorkbook
Call create_Sheetarray
Call spur_String_out
Call QuickSort_Sheets(sheetArray, LBound(sheetArray), UBound(sheetArray))
Call spur_String_in
For i = UBound(sheetArray) To 1 Step -1
wb.Sheets(sheetArray(i - 1)).Move before:=wb.Sheets(3) '1 u. 2 sind bei mir feste  _
positionen
Next
End Sub
Sub create_Sheetarray()
Dim ws As Worksheet
Dim wb As Workbook
Dim i As Long
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If Left(ws.Name, 5) = "Spur_" Then
ReDim Preserve sheetArray(i)
sheetArray(i) = ws.Name
i = i + 1
End If
Next ws
End Sub
Sub spur_String_out()
Dim i As Long
Dim j As Long
For i = 0 To UBound(sheetArray)
j = Len(sheetArray(i)) - 5
If IsNumeric(Right(sheetArray(i), j)) Then
sheetArray(i) = Right(sheetArray(i), j)
End If
Next i
End Sub
Sub spur_String_in()
Dim i As Long
For i = 0 To UBound(sheetArray)
If IsNumeric(sheetArray(i)) Then
sheetArray(i) = "Spur_" & sheetArray(i)
Debug.Print sheetArray(i)
End If
Next i
End Sub
Sub QuickSort_Sheets(ByRef arrSheets() As Variant, _
ByVal i As Long, _
ByVal j As Long)
Dim x As Long, y As Long
Dim ref As Long, temp As Long
x = i: y = j
ref = arrSheets((x + y) / 2)
Do
Do While arrSheets(x)  ref
y = y - 1
Debug.Print "y = " & y & "   ref = " & ref
Loop
If x  y)
If i

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread