Option Explicit
Option Compare Text

Sub SortTheSheets()
    Dim B As Boolean
    Dim s As String

    ' sort all sheets in ascending order by name
.
    B = SortWorksheetsByName(0, 0, s, False)

    If B = True Then
        MsgBox "Worksheets Sorted"
    Else
        MsgBox "Error sorting sheets: " & s
    End If

End Sub

Public Function SortWorksheetsByName(ByVal FirstToSort As Long, _
	ByVal LastToSort As Long, _
 	ByRef ErrorText As String, _
	Optional ByVal SortDescending As Boolean = False) As Boolean

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortWorksheetsByName
' This sorts the worskheets from FirstToSort to LastToSort by name
' in either ascending (default) or descending order. If successful,
' ErrorText is vbNullString and the function returns True. If
' unsuccessful, ErrorText gets the reason why the function failed
' and the function returns False.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim M, N As Long
Dim WB As Workbook
Dim B As Boolean

Set WB = Worksheets.Parent
ErrorText = vbNullString

If WB.ProtectStructure = True Then
    ErrorText = "Workbook is protected."
    SortWorksheetsByName = False
End If
    
'''''''''''''''''''''''''''''''''''''''''''''''
' If First and Last are both 0, sort all sheets.
'''''''''''''''''''''''''''''''''''''''''''''''

If (FirstToSort = 0) And (LastToSort = 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
Else
    '''''''''''''''''''''''''''''''''''''''
    ' More than one sheet selected. We
    ' can sort only if the selected
    ' sheet are adjacent.
    '''''''''''''''''''''''''''''''''''''''
    B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)

    If B = False Then
        SortWorksheetsByName = False
        Exit Function
    End If

End If

'''''''''''''''''''''''''''''''''''''''''''''
' Do the sort, essentially a Bubble Sort.
'''''''''''''''''''''''''''''''''''''''''''''
For M = FirstToSort To LastToSort
    For N = M To LastToSort
        If SortDescending = True Then
            If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) > 0 Then
                WB.Worksheets(N).Move before:=WB.Worksheets(M)
            End If
        Else
            If StrComp(WB.Worksheets(N).Name, WB.Worksheets(M).Name, vbTextCompare) < 0 Then
                WB.Worksheets(N).Move before:=WB.Worksheets(M)
            End If
        End If
    Next N
Next M

SortWorksheetsByName = True

End Function

Public Function SortWorksheetsByNameArray(NameArray() As Variant, ByRef ErrorText As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' WorksheetSortByArray
' This procedure sorts the worksheets named in NameArray to the order in
' which they appear in NameArray. The adjacent elements in NameArray need
' not be adjacent sheets, but the collection of all sheets named in
' NameArray must form a set of adjacent sheets. If successful, returns
' True and ErrorText is vbNullString. If failure, returns False and
' ErrorText contains reason for failure.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Arr() As Long
Dim N As Long
Dim M As Long
Dim L As Long
Dim WB As Workbook

ErrorText = vbNullString

'''''''''''''''''''''''''''''''''''''''''''''''
' The NameArray need not contain all of the
' worksheets in the workbook, but the sheets
' that it does name together must form a group of
' adjacent sheets. Sheets named in NameArray
' need not be adjacent in the NameArray, only
' that when all sheet taken together, they form an
' adjacent group of sheets
'''''''''''''''''''''''''''''''''''''''''''''''
ReDim Arr(LBound(NameArray) To UBound(NameArray))
On Error Resume Next
For N = LBound(NameArray) To UBound(NameArray)
    '''''''''''''''''''''''''''''''''''''''
    ' Ensure all sheets in name array exist
    '''''''''''''''''''''''''''''''''''''''
    Err.Clear
    M = Len(WB.Worksheets(NameArray(N)).Name)
    If Err.Number <> 0 Then
        ErrorText = "Worksheet does not exist."
        SortWorksheetsByNameArray = False
        Exit Function
    End If
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Put the index value of the sheet into Arr. Ensure there
    ' are no duplicates. If Arr(N) is not zero, we've already
    ' loaded that element of Arr and thus have duplicate sheet
    ' names.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Arr(N) > 0 Then
        ErrorText = "Duplicate worksheet name in NameArray."
        SortWorksheetsByNameArray = False
        Exit Function
    End If
        
    Arr(N) = Worksheets(NameArray(N)).Index
Next N

'''''''''''''''''''''''''''''''''''''''
' Sort the sheet indexes. We don't use
' these for the sorting order, but we
' do use them to ensure that the group
' of sheets passed in NameArray are
' together contiguous.
'''''''''''''''''''''''''''''''''''''''
For M = LBound(Arr) To UBound(Arr)
    For N = M To UBound(Arr)
        If Arr(N) < Arr(M) Then
            L = Arr(N)
            Arr(N) = Arr(M)
            Arr(M) = L
        End If
    Next N
Next M
''''''''''''''''''''''''''''''''''''''''
' Now that Arr is sorted ascending, ensure
' that the elements are in order differing
' by exactly 1. Otherwise, sheet are not
' adjacent.
'''''''''''''''''''''''''''''''''''''''''
If ArrayElementsInOrder(Arr:=Arr, Descending:=False, Diff:=1) = False Then
    ErrorText = "Specified sheets are not adjacent."
    SortWorksheetsByNameArray = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Now, do the actual move of the sheets.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo 0
WB.Worksheets(NameArray(LBound(NameArray))).Move before:=WB.Worksheets(Arr(1))
For N = LBound(NameArray) + 1 To UBound(NameArray) - 1
    WB.Worksheets(NameArray(N)).Move before:=WB.Worksheets(NameArray(N + 1))
Next N

SortWorksheetsByNameArray = True


End Function


Public Function SortingWorksheetesByCellValue(ByVal FirstToSort As Long, LastToSort As Long, _
    RangeSpec As String, ByRef ErrorText As String, Optional Descending As Boolean = False) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortingWorksheetesByCellValue
' This procedure allow you to sort worksheets in either ascending or
' descending order by a cell value on each worksheet. The RangeSpec
' should be a text description of a cell (e.g., "A1") that exists
' on all cells.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim N As Long
Dim M As Long
Dim Rng As Range
Dim WB As Workbook
Dim B As Boolean

ErrorText = vbNullString
Set WB = Worksheets.Parent

If (FirstToSort <= 0) And (LastToSort <= 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
Else
    B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
    If B = False Then
        SortingWorksheetesByCellValue = False
        Exit Function
    End If
End If

''''''''''''''''''''''''''''''''''''''''
' Ensure RangeSpec exists on each sheet
''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For N = FirstToSort To LastToSort
    Err.Clear
    Set Rng = WB.Worksheets(N).Range(RangeSpec)
    If Err.Number <> 0 Then
       ErrorText = "RangeSpecification does not exist on all sheets."
       SortingWorksheetesByCellValue = False
        Exit Function
    End If
    Err.Clear
    If IsNumeric(WB.Worksheets(N).Range(RangeSpec).Value) = False Then
        SortingWorksheetesByCellValue = False
        ErrorText = "RangeSpec is not numeric"
        Exit Function
    End If
       
Next N
On Error GoTo 0
'''''''''''''''''''''''''''''''''''''
' Sort the sheets with a Bubble Sort.
'''''''''''''''''''''''''''''''''''''
For M = FirstToSort To LastToSort
    For N = M To LastToSort
        If Descending = True Then
            If WB.Worksheets(M).Range(RangeSpec).Value < WB.Worksheets(N).Range(RangeSpec).Value Then
                WB.Worksheets(M).Move before:=WB.Worksheets(N)
            End If
        Else
            If WB.Worksheets(M).Range(RangeSpec).Value > WB.Worksheets(N).Range(RangeSpec).Value Then
                WB.Worksheets(N).Move before:=WB.Worksheets(M)
            End If
        End If
    Next N
Next M

SortingWorksheetesByCellValue = True

End Function


Public Function GroupSheetsByColor(ByVal FirstToSort As Long, ByVal LastToSort As Long, _
    ByRef ErrorText As String, ColorArray() As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GroupSheetsByColor
' This groups worksheets by color. The order of the colors
' to group by must be the ColorIndex values stored in
' ColorsArray.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim WB As Workbook
Dim B As Boolean
Dim N1 As Long
Dim N2 As Long
Dim N3 As Long
Dim CI1 As Long
Dim CI2 As Long
Dim CArray As Variant

Dim CNdx1 As Long
Dim Cndx2 As Long

If IsArrayAllocated(ColorArray) = False Then
    ErrorText = "ColorArray is not a valid, allocated array."
    GroupSheetsByColor = False
    Exit Function
End If

'ReDim CArray(LBound(ColorArray) To UBound(ColorArray))
'For N1 = LBound(ColorArray) To UBound(ColorArray)
'    CArray(N1) = ColorArray(N1)
'Next N1
    

Const MIN_COLOR_INDEX = 1
Const MAX_COLOR_INDEX = 56

Set WB = Worksheets.Parent
ErrorText = vbNullString


''''''''''''''''''''''''''''''''''''''
' Setup ColorIndex array
''''''''''''''''''''''''''''''''''''''
If IsMissing(ColorArray) = False Then
    If IsArray(ColorArray) = False Then
        ErrorText = "ColorArray is not an array"
        GroupSheetsByColor = False
        Exit Function
    End If
Else
    ''''''''''''''''''''''''''''''''''''''
    ' Ensure all color indexes are valid.
    ''''''''''''''''''''''''''''''''''''''
    For N1 = LBound(ColorArray) To UBound(ColorArray)
        If (ColorArray(N1) > MAX_COLOR_INDEX) Or (ColorArray(N1) < MIN_COLOR_INDEX) Then
            ErrorText = "Invalid ColorIndex in ColorArray"
            GroupSheetsByColor = False
            Exit Function
        End If
    Next N1
End If

'CArray = ColorArray

Set WB = Worksheets.Parent

ErrorText = vbNullString

If (FirstToSort <= 0) And (LastToSort <= 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
End If

B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
If B = False Then
    GroupSheetsByColor = False
    Exit Function
End If

For N1 = FirstToSort To LastToSort
    If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(LBound(ColorArray)) Then
        WB.Worksheets(N1).Move before:=WB.Worksheets(1)
        Exit For
    End If
Next N1
N3 = 1
For N2 = LBound(ColorArray) To UBound(ColorArray)
    For N1 = 2 To LastToSort
        If WB.Worksheets(N1).Tab.ColorIndex = ColorArray(N2) Then
            WB.Worksheets(N1).Move After:=WB.Worksheets(N3)
            N3 = N3 + 1
        End If
        
    Next N1
Next N2

GroupSheetsByColor = True

End Function

Public Function SortSheetsByRangeList(FirstToSort As Long, LastToSort As Long, _
    ListRange As Range, ByRef ErrorText As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SortSheetsByRangeList
' This orders the worksheets in the order defined by the values in ListRange.
' The number of cells in ListRange must be equal to (LastToSort - FirstToSort +1)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
Dim Rng As Range
Dim N As Long
Dim WB As Workbook
Dim B As Boolean


ErrorText = vbNullString
Set WB = Worksheets.Parent

If (FirstToSort <= 0) And (LastToSort <= 0) Then
    FirstToSort = 1
    LastToSort = WB.Worksheets.Count
Else
    B = TestFirstLastSort(FirstToSort, LastToSort, ErrorText)
    If B = False Then
        SortSheetsByRangeList = False
        Exit Function
    End If
End If
N = 1
For Each Rng In ListRange.Cells
    If SheetExists(Rng.Text, WB) = True Then
        WB.Worksheets(Rng.Text).Move before:=WB.Worksheets(N)
        N = N + 1
    End If
Next Rng

    
    
End Function


Private Function ArrayElementsInOrder(Arr As Variant, _
    Optional Descending As Boolean = False, _
    Optional Diff As Integer = 0) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ArrayElementsInOrder
' This function tests an array of integers (Long or Int) to determine
' if they are in order, in ascending or descending sort order, and
' optionally if they all differ by exactly Diff. Diff is the absolute
' value between two adjacent elements. Do not use a negative number
' for a descending sort; Diff should always be greater than 0 to test
' the differences or 0 to ignore differences. The default behavior
' is to test whether the elements are in ascending order with any
' difference between them. Set the Descending and/or Diff parameters
' to change this.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
For N = LBound(Arr) To UBound(Arr) - 1
    If Descending = False Then
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) - Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) > Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    Else
        If Diff > 0 Then
            If Arr(N) <> Arr(N + 1) + Diff Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        Else
            If Arr(N) < Arr(N + 1) Then
                ArrayElementsInOrder = False
                Exit Function
            End If
        End If
    End If
Next N
ArrayElementsInOrder = True
End Function



Private Function TestFirstLastSort(FirstToSort As Long, LastToSort As Long, _
    ByRef ErrorText As String) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' TestFirstLastSort
' This ensures FirstToSort and LastToSort are valid values. If successful,
' returns True and sets ErrorText to vbNullString. If unsuccessful, returns
' False and set ErrorText to the reason for failure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ErrorText = vbNullString
If FirstToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is less than or equal to 0."
    Exit Function
End If

If FirstToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than number of sheets."
    Exit Function
End If

If LastToSort <= 0 Then
    TestFirstLastSort = False
    ErrorText = "LastToSort is less than or equal to 0."
    Exit Function
End If

If LastToSort > Worksheets.Count Then
    TestFirstLastSort = False
    ErrorText = "LastToSort greater than number of sheets."
    Exit Function
End If

If FirstToSort > LastToSort Then
    TestFirstLastSort = False
    ErrorText = "FirstToSort is greater than LastToSort."
    Exit Function
End If
    
TestFirstLastSort = True

End Function


Private Function IsArrayAllocated(Arr As Variant) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsArrayAllocated
' Returns True or False indicating if Arr is an allocated
' array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    On Error Resume Next
    Dim V As Variant
    IsArrayAllocated = True
    V = Arr(LBound(Arr, 1))
    If IsError(V) = True Then
        IsArrayAllocated = False
    End If
    If (UBound(Arr, 1) < LBound(Arr, 1)) Then
        IsArrayAllocated = False
    End If
    
End Function

Private Function SheetExists(WSName As String, Optional WB As Workbook = Nothing) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SheetExists
' Returns True if worksheet named by WSName exists in
' Workbook WB. If WB is omitted,
' the ActiveWorkbook is used.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
SheetExists = IsError(IIf(WB Is Nothing, ActiveWorkbook, WB).Worksheets(WSName)) = False

End Function