Tabellenblätter sortieren
04.02.2009 10:38:00
Alex
hier ist mein gesamter Code abgebildet, den ich mir aus Recherche und mit eurer Hilfe zusammengebastelt habe.
Die Arbeitsmappe umfasst ca. 150 Tabellenblätter.
Der Code funktioniert.
Aber: er benötigt sehr viel Zeit bis er die Aktion ausgeführt hat.
Durch mein Testen (indem ich die Einzelcodes getrennt und dann nacheinander ablaufen ließ) fand ich heraus, dass er ab dem Teil : 'Alph.Sortierung der Tabellen gem. Übersicht Spalte A (für das alphabet. Sortieren der Tabellenblätter) fast 3 Minuten benötigt.
Meine Frage: Ist es "normal", dass es beim sortieren von ca 150 Tabellenblättern so lange dauert?
Wenn Ja, dann gehts halt nicht anders...ok.
Oder übersehe ich etwas? Z.B.: Blattschutz vorher alle Aufheben....ect.
Weiß jemand Rat?
Sub AuflistungUndSheetsSortieren()
Dim Blatt As Object 'Blattname aus Zelle des Blattes
Dim i As Long, j As Long 'Auflistung aller Tabellen so wie ihre momentane Reihenfolge _
ist
Dim x As String 'Auflistung aller Tabellen so wie ihre momentane _
Reihenfolge ist
Dim all As Long 'Auflistung aller Tabellen so wie ihre momentane _
Reihenfolge ist
Dim shArray() 'Auflistung aller Tabellen so wie ihre momentane _
Reihenfolge ist
Dim Zelle As Range 'Alph.Sortierung gem. Spalte A
'sheets sichtbar machen
Application.ScreenUpdating = False
For inI = Sheets.Count To 1 Step -1
Sheets(inI).Visible = True
Next inI
Application.ScreenUpdating = True
'Blattname aus Zelle des Blattes
On Error Resume Next
For Each Blatt In ActiveWorkbook.Worksheets
'"Übersicht" ; "Grundformular" ; "ListeHäufigerEintragungen" ; "Übersicht Sport"
If Blatt.Name "Übersicht" And _
Blatt.Name "Grundformular" And _
Blatt.Name "ListeHäufigerEintragungen" And _
Blatt.Name "Übersicht Sport" Then
With Blatt
If .Cells(4, 1) "" Then
.Name = .Cells(4, 1) 'zelle A4 (1.Spalte,4.Zeile)
Else
.Name = "zzz" & .CodeName
End If
End With
End If
Next Blatt
'Auflistung (in Spalte C) aller Tabellen so wie ihre momentane Reihenfolge im Workbook ist
Sheets("Übersicht Sport").Unprotect "Kennwort"
all = ThisWorkbook.Worksheets.Count
ReDim shArray(5 To all)
On Error Resume Next
For i = 5 To all '5 to all = ab dem Blatt das momentan auf Platz 5 liegt
x = ThisWorkbook.Sheets(i).Name
shArray(i) = x
Next i
For j = LBound(shArray) To UBound(shArray)
Sheets(4).Cells(j + 1, 3) = shArray(j) 'C...ab wohin die Namen in Übersicht Schieß _
_
en geschrieben werden j + 1 = 2.Zeile, 3 = 3.Spalte
Next j
'alphab. Sortierung Übersicht Schießen ab C6 - S153
Sheets("Übersicht Sport").Select
Range("C6:S153").Select
Selection.Sort Key1:=Range("C6"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("J1").Select
Sheets("Übersicht Sport").Protect "Kennwort", DrawingObjects:=True, Contents:=True, Scenarios:= _
_
True
'Alph.Sortierung der Tabellen gem. Übersicht Spalte A
Sheets("Übersicht").Unprotect "Kennwort"
Sheets("Übersicht").Select
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = False
For Each Zelle In Sheets("Übersicht").Range("A5").CurrentRegion.Cells
Sheets(Zelle.Value).Move after:=Sheets(ThisWorkbook.Sheets.Count)
Next
Sheets("Übersicht").Select
Range("A5").Select
'sheets unsichtbar machen außer Übersicht
For inI = Sheets.Count To 1 Step -1
If LCase(Sheets(inI).Name) LCase("Übersicht") Then
Sheets(inI).Visible = False
End If
Next inI
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Sheets("Übersicht").Select
Sheets("Übersicht").Protect "Kennwort", DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("A5").Select
End Sub
Danke vorab an alle
Alex