Microsoft Excel

Herbers Excel/VBA-Archiv

Code optimieren?


Betrifft: Code optimieren? von: Max2
Geschrieben am: 27.04.2017 14:34:53

Hallo Leute,

ich möchte Tabellen "sortieren", dafür habe ich einen kleinen Code geschrieben.

Dort erstelle ich eine ArrayList und Nutze ArrayList.Sort um mir Arbeit und Mühe zu sparen.

Blattnamen sind wie folgt: Doku, Übersicht, Spur_1 bis xy
Das blatt "Doku" soll an pos1, das Blatt "Übersicht" an pos2(wird jetzt immer an letzte Position geschoben), die Spuren dann nach Größe der Zahl(das macht mir .Sort schon)

Mein Code gefällt mir aber nicht wirklich... kommt ihr auf was besseres oder schnelleres?

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

  

Betrifft: AW: Code optimieren? von: ChrisL
Geschrieben am: 27.04.2017 14:55:48

Hi Max

Mir gefällt der Code :)

Den Umweg über Collection könnte man sich sparen, aber schlimm ist es auch nicht. Siehe Web für alternative Fertigcodes z.B.
https://www.herber.de/forum/archiv/144to148/147277_Blaetter_sortieren_mittels_VBACode.html
http://www.chip.de/news/Tabellenblaetter-in-Excel-alphabetisch-sortieren-So-funktioniert-s_57785605.html

Anstatt die beiden Ausnahmen direkt im Sortier-Makro zu definieren, würde ich die beiden Blätter nach erfolgter Sortierung noch einmal verschieben.

Worksheets("Übersicht").Move Before:=Worksheets(1)
Worksheets("Doku").Move Before:=Worksheets(1)

cu
Chris


  

Betrifft: AW: Code optimieren? von: Daniel
Geschrieben am: 27.04.2017 15:39:10

Hi
die Do-Schleife um die Blätter in Reihenfolge zu bringen ist unnötig.
das geht mit einem einfachen For-Next.

Im Prinzip sollte dieser Code reichen:

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
Gruß Daniel


  

Betrifft: Danke euch beiden! Geschlossen von: Max2
Geschrieben am: 27.04.2017 16:25:39

Hallo,

vielen Dank für eure Hilfe und Feedback.

Das ich auf die For Schleife nicht gekommen bin ärgert mich, aber was solls, aus Fehlern lernt man.


  

Betrifft: kleines Update und Code für euch von: Max2
Geschrieben am: 28.04.2017 10:06:28

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
            x = x + 1
            Debug.Print "x = " & x & "   ref = " & ref
        Loop
        
        Do While arrSheets(y) > ref
            y = y - 1
            Debug.Print "y = " & y & "   ref = " & ref
        Loop
        
        If x <= y Then
            temp = arrSheets(x)
            arrSheets(x) = arrSheets(y)
            arrSheets(y) = temp
            
            x = x + 1
            y = y - 1
        End If
    Loop Until (x > y)
    
    If i < y Then Call QuickSort_Sheets(arrSheets, i, y)
    If x < j Then Call QuickSort_Sheets(arrSheets, x, j)
        
End Sub




  

Betrifft: AW: kleines Update und Code für euch von: Daniel
Geschrieben am: 28.04.2017 13:32:05

Hi
naja, ist doch logisch.
Texte können nur nach Textregeln sortiert werden und da ist das erste unterschiedliche Zeichen für die Reihenfolge von zwei Texten entscheidend.

enthält der Text mehrstellige Zahlen, die sortierrelevant sind, so sorgt man mit führenden Nullen für eine gleiche Stellenzahl:

xxx_01
xxx_02
...
xxx_11
xxx_12
...
xxx_22

Gruß Daniel


  

Betrifft: Danke das wusste ich nicht, aber... von: Max2
Geschrieben am: 28.04.2017 15:11:42

ich habe die ArrayList vor der Sortierung geändert, so dass eben nur noch die Zahlen drinnen stehen.

Die .Sort Funktion einer ArrayList ermittelt selbst, ob es sich um Strings oder Integers handelt.

Es wurden also die Zahlen nicht richtig sortiert bei mir, wahrscheinlich weil er Sie als Strings angesehen hat... vor einfügen in die ArrayList habe ich aber extra nochmal mit CInt die "Strings" in Zahlen umgewandelt.
War der List aber egal...

Das ganze verwundert mich, da ich die .Sort Geschichte schon ein paar mal benutzt habe und es da immer einwandfrei ging.