Sortieren Tabellenblätter und löschen

Sub SortSheetsAufsteigend() Dim Cnt As Integer, n As Integer, M As Integer Dim WS As Worksheet Set WS = ActiveSheet Cnt = ActiveWorkbook.Worksheets.Count For M = 1 To Cnt For n = M To Cnt If Worksheets(n).Name

Sub SortSheetsAbsteigend() Dim Cnt As Integer, n As Integer, M As Integer Dim WS As Worksheet Set WS = ActiveSheet Cnt = ActiveWorkbook.Worksheets.Count For M = 1 To Cnt For n = M To Cnt If Worksheets(n).Name > Worksheets(M).Name Then Worksheets(n).Move before:=Worksheets(M) End If Next n Next M End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
versuch es mal so.

Option Explicit

Sub SortTabelle()
Dim meAr(), i As Integer

'absteigend = True, aufsteigend = False 
Const SortAbsteigend As Boolean = True
 
With ThisWorkbook
    Redim meAr(.Sheets.Count - 1)
     
    For i = 1 To ThisWorkbook.Sheets.Count
        meAr(i - 1) = .Sheets(i).Name
        If IsNumeric(meAr(i - 1)) Then meAr(i - 1) = meAr(i - 1) * 1
    Next i
     
    QuickSort meAr, Lbound(meAr), Ubound(meAr)
     
    Application.ScreenUpdating = False
        If SortAbsteigend Then
            'sortiere absteigend 
            For i = Ubound(meAr) To Lbound(meAr) + 1 Step -1
                .Sheets(CStr(meAr(i))).Move Before:=.Sheets(Ubound(meAr) - i + 1)
            Next i
        Else
            'sortiere aufsteigend 
            For i = Ubound(meAr) To Lbound(meAr) Step -1
                .Sheets(CStr(meAr(i))).Move After:=.Sheets(i + 1)
            Next i
        End If
    Application.ScreenUpdating = True
 
End With
End Sub

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

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) j = j - 1 Loop If i j QuickSort sArray, MinElem, j QuickSort sArray, i, MaxElem End Sub

Hallo Robert/Tino,
stimmt in der Beispieldatei geht es.
Hier mal mein Beispiel als Screenshot.
https://www.herber.de/bbs/user/71636.xls
Die Reihenfolge stimmt nicht, bei den Eigenschaften sieht man ja, dass es 2 Namen gibt einmal (Name) und einmal Name.
Kann es daran liegen, dass ich ein paar Blätter ausgeblendet habe?
Es wäre zwar nett wenn das geht, ist aber nicht mehr so lebenswichtig weil ich jetzt die Kundennummern manipuliere (jetzt nur noch von 100-...).
Wichtig wäre für mich alle Tabellenblätter von 100-... markieren und drucken und anschließend löschen zu können - habt ihr da eine Idee?
Ich habe es mal mit
ActiveWorkbook.Sheets.Select versucht und würde sonst alle andern Blätter dektivieren, geht aber in meiner Datei auch nicht, wahrscheinlich wegen der ausgeblendeten Blätter.
Ich habe auch keinen Befehl gefunden mit dem man ein Blatt aus der Selection nehmen kann - kennt Ihr was?
Also braucht man wohl eine Schleife die alle Tabellenblätter von 1-99999 selektiert. Das kann ich dann drucken und anschliessend löschen...
Viele Grüße Jens

Sub Suchen_Drucken_Loeschen() Dim i As Integer With Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False .Calculation = xlCalculationManual With ThisWorkbook For i = .Sheets.Count To 1 Step -1 'Ist Tabellenname eine Zahl? If IsNumeric(.Sheets(i).Name) Then 'Tabelle ausdrucken ' .Sheets(i).PrintOut 'kurz warten, damit Druckauftrag verarbeitet werden kann 'eventuell Zeit anpassen Application.Wait Now + TimeSerial(0, 0, 2) DoEvents 'Tabelle löschen .Sheets(i).Delete End If Next i End With .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .ScreenUpdating = True End With End Sub

Sub aaaaaTabellenLöschenZahl() Dim wksWS As Worksheet Application.DisplayAlerts = False For Each wksWS In ActiveWorkbook.Worksheets If Val(wksWS.Name) > 0 Then wksWS.Delete End If Next wksWS Sheets("(Leer)").Select ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True End Sub

Beliebteste Forumthreads (12 Monate)

Sortieren Tabellenblätter und löschen

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread