Wie kann ich Blätter in einer bestimmten Reihenfolge alphabetisch neu anordnen?

Ich muss meine Blätter in einer bestimmten Reihenfolge neu anordnen. Wenn noch welche übrig sind, tun Sie dies alphabetisch. Ich habe das Makro unten, um sie alphabetisch neu zu ordnen.

Wenn ich die Blätter "METALS", "SVOC", "GENCHEM" usw. habe, möchte ich, dass diese immer in alphabetischer Reihenfolge vorliegen. Danach sollten alle anderen Blätter "Apple", "Zebra", "Lion" folgen alphabetischer Reihenfolge.

Ich habe diesen Code ausprobiert, aber nicht geklappt

Sheets("GENCHEM").Move Before:=Sheets(1)
Sheets("METALS").Move Before:=Sheets(2)
Sheets("PCBS").Move Before:=Sheets(3)
Sheets("OC_PEST").Move Before:=Sheets(4)
Sheets("SVOC").Move Before:=Sheets(5)
Sheets("VOC").Move Before:=Sheets(6)

'------- Mein Arbeitsmakro unten ----

Option Explicit
Sub reordersheets()
'---Reorders the Sheets---
Dim N As Integer
Dim M As Integer
Dim FirstWSToSort As Integer
Dim LastWSToSort As Integer
Dim SortDescending As Boolean

SortDescending = False

If ActiveWindow.SelectedSheets.Count = 1 Then

    FirstWSToSort = 1
    LastWSToSort = Worksheets.Count
Else
    With ActiveWindow.SelectedSheets
        For N = 2 To .Count
            If .Item(N - 1).Index <> .Item(N).Index - 1 Then
                MsgBox "You cannot sort non-adjacent sheets"
                Exit Sub
            End If
        Next N
        FirstWSToSort = .Item(1).Index
        LastWSToSort = .Item(.Count).Index
    End With
End If

For M = FirstWSToSort To LastWSToSort
    For N = M To LastWSToSort
        If SortDescending = True Then
            If UCase(Worksheets(N).Name) > UCase(Worksheets(M).Name) Then
                Worksheets(N).Move Before:=Worksheets(M)
            End If
        Else
            If UCase(Worksheets(N).Name) < UCase(Worksheets(M).Name) Then
                Worksheets(N).Move Before:=Worksheets(M)
            End If
        End If
    Next N
Next M

End Sub

Ich habe den Code irgendwie neu geschrieben. Das funktioniert bei mir. Beachten Sie, dass ich die speziellen Blätter, die Sie zu Beginn benötigen, mithilfe eines Arrays "brutal erzwinge".

Option Base 1

Sub t()
Dim shtArray() As String
Dim i       As Long, k As Long
Dim ws      As Worksheet
Dim R       As Range
Dim n       As Long

' Let's "brute force" your specific sheets to the front
Dim exceptionSheets() As Variant
exceptionSheets = Array("GENCHEM", "METALS", "OC_PEST", "PCBS", "SVOC", "VOC")

For i = 1 To ActiveWorkbook.Sheets.Count
    If Not UBound(Filter(exceptionSheets, ActiveWorkbook.Sheets(i).Name)) > -1 Then
        k = k + 1
        Debug.Print Sheets(i).Name
        ReDim Preserve shtArray(k)
        shtArray(k) = ActiveWorkbook.Sheets(i).Name
    End If
Next i

Application.ScreenUpdating = False
'  Thanks to http://www.cpearson.com/excel/SortingArrays.aspx
' create a new sheet
Set ws = ThisWorkbook.Worksheets.Add

' put the array values on the worksheet
Set R = ws.Range("A1").Resize(UBound(shtArray) - LBound(shtArray) + 1, 1)
R = Application.Transpose(shtArray)

' sort the range
R.Sort key1:=R, order1:=xlAscending, MatchCase:=False

' load the worksheet values back into the array
For n = 1 To R.Rows.Count
    shtArray(n) = R(n, 1)
Next n

' delete the temporary sheet
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

' Now, sort the sheets.
For i = UBound(exceptionSheets) To 1 Step -1
    Sheets(exceptionSheets(i)).Move after:=Sheets(1)
Next i

For i = UBound(shtArray) To LBound(shtArray) Step -1
    Sheets(shtArray(i)).Move after:=Sheets(7 + i - 1)
Next i

End Sub

Ich habe den folgenden Code verwendet. ''     Sub SortWorksheetsTabs ()     Application.ScreenUpdating = False     Dim ShCount As Integer, i As Integer, j As Integer     ShCount = Sheets.Count     Für i = 1 bis ShCount - 1       Für j = i + 1 To ShCount         Wenn UCase (Sheets (j) .Name) & lt; UCase (Sheets (i) .Name) Dann             Blätter (j). Vorher bewegen: = Blätter (i)         End If       Weiter j     Weiter i     Application.ScreenUpdating = True     End Sub ''