AW: Register nach Farbe und Name sortieren
29.08.2010 15:19:46
fcs
Hallo Friedrich,
hier Prozeduren zum Sortieren.
Diese in einem allgemeinen Modul einfügen und das Makro SortSheets an passender Stelle mit
Call SheetSort
starten oder manuell starten.
Gruß
Franz
Public Sub SheetSort()
Dim arrTabNames() As String, arrSheets() As Variant, arrTabColors() As Long
Dim iTab As Long, iIndex As Long, iColor As Long, bvorhanden As Boolean
With ActiveWorkbook
iTab = .Sheets.Count
ReDim arrTabNames(1 To iTab)
ReDim arrSheets(1 To iTab, 1 To 2)
iColor = 0
'Blattnamen und Tab-Farben(ohne Doppelte) in Array lesen
For iTab = 1 To .Sheets.Count
arrTabNames(iTab) = .Sheets(iTab).Name
If iTab = 1 Then
iColor = iColor + 1
ReDim arrTabColors(1 To iColor)
arrTabColors(iColor) = Sheets(iTab).Tab.Color
Else
bvorhanden = False
For iIndex = 1 To iColor
If arrTabColors(iIndex) = Sheets(iTab).Tab.Color Then
bvorhanden = True
Exit For
End If
Next
If bvorhanden = False Then
iColor = iColor + 1
ReDim Preserve arrTabColors(1 To iColor)
arrTabColors(iColor) = Sheets(iTab).Tab.Color
End If
End If
Next
'Arrays sortieren
Call QuickSort(VA_array:=arrTabNames)
Call QuickSort(VA_array:=arrTabColors)
'Blattnamen und Farben in Sortierreihenfolge der Blätter in ein Array einlesen
For iTab = 1 To .Sheets.Count
arrSheets(iTab, 1) = Sheets(arrTabNames(iTab)).Tab.Color
arrSheets(iTab, 2) = arrTabNames(iTab)
Next
'Blätter in Reihenfolge von Farben und Namen verschieben
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
For iIndex = 1 To iColor
For iTab = 1 To .Sheets.Count
If arrSheets(iTab, 1) = arrTabColors(iIndex) Then
.Sheets(arrSheets(iTab, 2)).Move after:=.Sheets(.Sheets.Count)
End If
Next
Next
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End With
End Sub
Public Sub QuickSort(ByRef VA_array, Optional V_Low1, Optional V_high1)
On Error Resume Next
Dim V_Low2, V_high2, V_loop As Integer
Dim V_val1, V_val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_array, 1)
End If
If IsMissing(V_high1) Then
V_high1 = UBound(VA_array, 1)
End If
V_Low2 = V_Low1
V_high2 = V_high1
V_val1 = VA_array((V_Low1 + V_high1) / 2)
While (V_Low2 V_val1 And _
V_high2 > V_Low1)
V_high2 = V_high2 - 1
Wend
If (V_Low2 V_Low1) Then Call _
QuickSort(VA_array, V_Low1, V_high2)
If (V_Low2