AW: Register einer bestimmten Farbe sortieren
26.06.2010 15:32:48
Tino
Hallo,
kannst mal diesen Code testen.
kommt als Code in Modul1
Option Explicit
Sub SortTabelle()
Dim meAr, i As Integer
FindTabsColorIndex 1, meAr
If IsArray(meAr) Then
With ThisWorkbook
QuickSort meAr, Lbound(meAr), Ubound(meAr)
Application.ScreenUpdating = False
For i = Ubound(meAr) To Lbound(meAr) + 1 Step -1
.Sheets(meAr(i)).Move After:=.Sheets(meAr(0))
Next i
Application.ScreenUpdating = True
End With
End If
End Sub
Sub FindTabsColorIndex(iColorIndex As Integer, meAr)
Dim i As Integer, ii As Integer
Dim tmpAr()
With ThisWorkbook
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Tab.ColorIndex = 1 Then
Redim Preserve tmpAr(ii)
tmpAr(ii) = .Sheets(i).Name
ii = ii + 1
End If
Next i
End With
If ii > 0 Then meAr = tmpAr
End Sub
kommt als Code in Modul2
Option Explicit
Sub QuickSort(ByRef sArray As Variant, ByVal MinElem As Long, MaxElem As Long)
Dim Mitte As Long
Dim vDummy As Variant
Dim i As Long, j As Long
If MinElem > MaxElem Then
Exit Sub
End If
Mitte = (MinElem + MaxElem) \ 2
i = MinElem
j = MaxElem
Do
Do While sArray(i) < sArray(Mitte)
i = i + 1
Loop
Do While sArray(j) > sArray(Mitte)
j = j - 1
Loop
If i <= j Then
vDummy = sArray(j)
sArray(j) = sArray(i)
sArray(i) = vDummy
i = i + 1
j = j - 1
End If
Loop Until i > j
QuickSort sArray, MinElem, j
QuickSort sArray, i, MaxElem
End Sub
Gruß Tino