Arbeitsblätter nach Datum sortieren

Hallo an Alle,
ich habe in einem Arbeitsblatt in den Zellen C9 und F9 je ein Anfangsdatum und ein Enddatum stehen. Nachdem ich diese Daten manuell eingegeben habe speichere ich diese Blätter mit dem Code :


Sub test()
Dim NewTabelName As String
'Neuen TabellenName aus Zelle A1 holen und merken
NewTabelName = ActiveSheet.Range("$d$3").Value
'Tabelle kopieren und hinter der letzten Tabelle einf?gen
ActiveSheet.Copy After:=Sheets(Sheets.Count)
'der neuen Tabelle den Name geben
Sheets(Sheets.Count).Name = NewTabelName
ActiveSheet.Select
Range("d3").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

unter dem in D3 mit & zusammengeführten Namen. Das klappt auch einwandfrei.
Nun suche ich eine Möglichkeit die Arbeitsblätter beim öffenen der Datei nach Ablaufdatum ( Zelle F9) zu sortieren, damit die demnächst ablaufenden Daten gleich im Sichtbereich liegen.
Das erste Arbeitsblatt wird generell als Eingabeblatt verwendet und soll nicht verschoben werden.
Hat jemand da eine Idee ?
Dank vorab
jan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Servus Jan,
probier mal das:


Private Sub Workbook_Open()
Call test
End Sub

in das Modul DieseArbeitsmappe und:
Option Explicit
Option Base 1
Sub test()
Dim DatArray() As Variant, SheetArray() As Variant
Dim i As Long
ReDim DatArray(1 To Sheets.Count)
ReDim SheetArray(1 To Sheets.Count)
For i = 1 To Sheets.Count
If i 1 Then
DatArray(i) = Sheets(i).Range("F9")
SheetArray(i) = Sheets(i).Name
Else
DatArray(i) = 0
SheetArray(i) = Sheets(i).Name
End If
Next i
Dim OG&, t&, j&, k&, h, y As Variant
OG = UBound(DatArray())
k = OG \ 2
While k > 0
For t = LBound(DatArray()) To OG - k
j = t
While (j >= 0) And (DatArray(j) > DatArray(j + k))
h = DatArray(j)
y = SheetArray(j)
DatArray(j) = DatArray(j + k)
SheetArray(j) = SheetArray(j + k)
DatArray(j + k) = h
SheetArray(j + k) = y
If j > k Then
j = j - k
Else
j = LBound(DatArray())
End If
Wend
Next t
k = k \ 2
Wend
For i = 2 To UBound(DatArray())
If Sheets(i).Name SheetArray(i) Then
Sheets(SheetArray(i)).Move After:=Sheets(i - 1)
End If
Next i
End Sub

in ein allgemeines Modul
Gruß
Chris

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter nach Datum sortieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Arbeitsblätter nach Datum sortieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread