Sorting and color-coding based on variables

Question

I have the following three macros all running in the same module. Each one is attached to its own button (3 buttons total). All three buttons take an average of 6-12 mins to run. As I am working on figuring out additional buttons that will check/review other criteria on the sheet, I am looking to improve this.

Could anyone help make these run quicker and/or look more elegant? I am still fairly new to VBA, so I am fairly sure there is a lot of redundancy in my code that is slowing it down and making it less elegant, I unfortunately don't know how to eliminate this. I've briefly explained the function of each code block below.

This first one removes existing color, then looks for any blanks, highlights them red, then for any " --Select--" cells in yellow. This is to make sure the sheet isn't missing info.

Sub ItemVal()
'Validation, Checks Sheet For Uncompleted Sections
Application.ScreenUpdating = False

'Clear Color
Dim Clear As Range
Set Clear = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    Cell.Interior.ColorIndex = 0
Next Cell

'Blank Cells
Dim BlankCel As Range
Set BlankCel = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    If Cell.Value = "" Then
        Cell.Interior.ColorIndex = 3
    End If
Next Cell


Dim ImagTemp As Range
Set ImagTemp = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    If Cell.Value = "Please Complete Image Template" Then
        Cell.Interior.ColorIndex = 6
    End If
Next Cell

'Selection
Dim InOut As Range
Set InOut = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    If Cell.Value = " --Select--" Then
        Cell.Interior.ColorIndex = 6
    End If
Next Cell


Dim YesNo As Range
Set YesNo = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    If Cell.Value = " --Select Yes or No--" Then
        Cell.Interior.ColorIndex = 6
    End If
Next Cell

Dim SugLocLis As Range
Set SugLocLis = ThisWorkbook.Sheets(1).Range("AM3:AM5002")
For Each Cell In Range("AM3:AM5002")
    If Cell.Value = " --" Then
        Cell.Interior.ColorIndex = 6
    End If
Next Cell

Application.ScreenUpdating = True


End Sub

This code clears all color again, then highlights each row based on the product type using specific colors, then sorts by that color. This is the slowest of the 3 macros:

Sub SortNColor()
'Sort + Colors Rows Based On Product Type

Application.ScreenUpdating = False

'Clear Color
Dim Clear As Range
Set Clear = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002")
    Cell.Interior.ColorIndex = 0
Next Cell

'Color Coding Code
Set MyPlage = Range("AG3:AG5002")

For Each Cell In MyPlage

    Select Case Cell.Value
    Case Is = "btty"
        Cell.EntireRow.Interior.ColorIndex = 20
    Case Is = "clfn"
        Cell.EntireRow.Interior.ColorIndex = 19
    Case Is = "chdr"
        Cell.EntireRow.Interior.ColorIndex = 24
    Case Is = "dskp"
        Cell.EntireRow.Interior.ColorIndex = 15
    Case Is = "flrp"
        Cell.EntireRow.Interior.ColorIndex = 16
    Case Is = "flmt"
        Cell.EntireRow.Interior.ColorIndex = 18
    Case Is = "lslt"
        Cell.EntireRow.Interior.ColorIndex = 35
    Case Is = "pdt"
        Cell.EntireRow.Interior.ColorIndex = 50
    Case Is = "pstt"
        Cell.EntireRow.Interior.ColorIndex = 36
    Case Is = "rcdl"
        Cell.EntireRow.Interior.ColorIndex = 37
    Case Is = "smflmt"
        Cell.EntireRow.Interior.ColorIndex = 38
    Case Is = "tblp"
        Cell.EntireRow.Interior.ColorIndex = 39
    Case Is = "trklt"
        Cell.EntireRow.Interior.ColorIndex = 40
    Case Is = "vty"
        Cell.EntireRow.Interior.ColorIndex = 20
    Case Is = "wsc"
        Cell.EntireRow.Interior.ColorIndex = 42
    Case Is = "ocf"
        Cell.EntireRow.Interior.ColorIndex = 43
    Case Is = "oflmt"
        Cell.EntireRow.Interior.ColorIndex = 44
    Case Is = "opnt"
        Cell.EntireRow.Interior.ColorIndex = 33
    Case Is = "osmflmt"
        Cell.EntireRow.Interior.ColorIndex = 32
    Case Is = "owsc"
        Cell.EntireRow.Interior.ColorIndex = 46
    Case Else
        Cell.EntireRow.Interior.ColorIndex = xlNone
    End Select
Next

'Sorting Code
Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet


Set ws = ActiveSheet
Set rngFirstRow = ws.Range("A3:FU3")
For Each rng In rngFirstRow.Cells
    With ws.Sort

        Set rngSort = rng.Resize(5000, 1)

        .SortFields.Clear

        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 255, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 255, 204)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 204, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(192, 192, 192)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(128, 128, 128)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 51, 102)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 255, 204)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(51, 153, 102)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 255, 153)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 204, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 153, 204)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 153, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 204, 153)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(51, 204, 204)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 204, 0)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 204, 0)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(0, 204, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(0, 0, 255)
        .SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 102, 0)


        .SetRange rngSort
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With
Next rng
Application.ScreenUpdating = True




End Sub

This one looks for any discontinued items and highlights them red and sorts them to the top. I couldn't get it to sort them to the bottom of the sheet, which would be preferred.

Sub DisRedSort()

Dim DISCONT As Range
Application.ScreenUpdating = False
    Set DISCONT = ThisWorkbook.Sheets(1).Range("C3:C5002")
    For Each Cell In Range("C3:C5002")
    If Cell.Value = "Discontinued" Then
        Cell.EntireRow.Interior.ColorIndex = 3
    End If
Next Cell


Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet
Set ws = ActiveSheet
Set rngFirstRow = ws.Range("A3:FU3")
For Each rng In rngFirstRow.Cells
    With ws.Sort

        Set rngSort = rng.Resize(5000, 1)

        .SortFields.Clear

.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 0, 0)


        .SetRange rngSort
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With
Next rng
Application.ScreenUpdating = True



End Sub

Answer 1

Not sure if adding another answer breaks protocol or not but OP made major edit to update his code with our suggestions and wanted to show this answer as a separate item.

After the edit to the code at 5pm UTC on 12-June, I want to make the following points:

The first part of your consolidated SortNColor is looping through individual cells just like ItemVal was before the revision. As my earlier answer shows, you can re-work this code into this:

Dim cellsFound As Range
Dim MyPlage As Range
Dim DISCONT As Range

    Set MyPlage = ThisWorkbook.Sheets(1).Range("AG3:AG5002")
    Set DISCONT = ThisWorkbook.Sheets(1).Range("C3:C5002")

    MyPlage.EntireRow.Interior.ColorIndex = xlNone

    Set cellsFound = FindAllOccurrences(MyPlage, "btty", True, True)
    If Not (cellsFound Is Nothing) Then
        cellsFound.EntireRow.Interior.ColorIndex = 20
    End If

    Set cellsFound = FindAllOccurrences(MyPlage, "clfn", True, True)
    If Not (cellsFound Is Nothing) Then
        cellsFound.EntireRow.Interior.ColorIndex = 19
    End If

    Set cellsFound = FindAllOccurrences(MyPlage, "chdr", True, True)
    If Not (cellsFound Is Nothing) Then
        cellsFound.EntireRow.Interior.ColorIndex = 24
    End If
' ...
' ... and so on for the other text values
' ...
'Colors Discontinued products
    Set cellsFound = FindAllOccurrences(DISCONT, "Discontinued", True, True)
    If Not (cellsFound Is Nothing) Then
        cellsFound.EntireRow.Interior.ColorIndex = 3
    End If

You can use the timing code from @paul to work out which bits of the code are slowest and then focus on those.

Having looked at your sort code again, I've just realised that the code in this answer above has coloured the entire row. So while your code looks like you are trying to sort each column separately, I think you are just trying to sort the data in A3:FU5002 (or similar range) and using the end column FU3:FU5002 as the sort key. I think your sort code should thus become:

'Sorting Code
Dim rngSortKey As Range
Dim rngSort As Range
Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets(1)
    Set rngSort = ws.Range("A3:FU5002")
    Set rngSortKey = ws.Range("FU3:FU5002")

    With ws.Sort
        .SortFields.Clear

        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 255, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 255, 204)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 204, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(192, 192, 192)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(128, 128, 128)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 51, 102)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 255, 204)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(51, 153, 102)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 255, 153)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 204, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 153, 204)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(204, 153, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 204, 153)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(51, 204, 204)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(153, 204, 0)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 204, 0)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(0, 204, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(0, 0, 255)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 102, 0)
        .SortFields.Add(rngSortKey, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                        SortOnValue.Color = RGB(255, 0, 0)

        .SetRange rngSort
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    End With

Answer 2

This is mainly looking at your first piece of code.

It is great that you are using Range variables and fully qualify them with the workbook and worksheet but you then do not use the variable. For, instance

Dim BlankCel As Range
Set BlankCel = ThisWorkbook.Sheets(1).Range("A3:FU5002")
For Each Cell In Range("A3:FU5002") ' change this line
    If Cell.Value = "" Then
        Cell.Interior.ColorIndex = 3
        End If
    Next Cell

You should replace the line marked with:

For Each Cell in BlankCel

Sometimes you can apply your action to the range in one go without having to loop. For example, Clear.Interior.ColorIndex = 0. You are also looping through the same range many times, each time testing for the value of the cell. Instead you should loop through the cells once and then test the value.

Sub ItemVal()

Dim Cell As Range
Dim rangeToTest As Range
Dim SugLocLis As Range

    'Validation, Checks Sheet For Uncompleted Sections
    Application.ScreenUpdating = False

    Set rangeToTest = ThisWorkbook.Sheets(1).Range("A3:FU5002")
    ' First, clear all the colours
    rangeToTest.Interior.ColorIndex = 0
    For Each Cell In rangeToTest.Cells
        Select Case Cell.Value
            Case ""
                Cell.Interior.ColorIndex = 3
            Case "Please Complete Image Template"
                Cell.Interior.ColorIndex = 6
            Case " --Select--"
                Cell.Interior.ColorIndex = 6
            Case " --Select Yes or No--"
                Cell.Interior.ColorIndex = 6
            Case Else
                ' Is there some default action to take?
        End Select
    Next Cell

    Set SugLocLis = ThisWorkbook.Sheets(1).Range("AM3:AM5002")
    For Each Cell In SugLocLis
        If Cell.Value = " --" Then
            Cell.Interior.ColorIndex = 6
        End If
    Next Cell

    Application.ScreenUpdating = True

End Sub

As an alternative, you could use the Range.Find method within a VBA function to return you just those that match the text you want. The Find method is pretty fast. Here is the function:

Public Function FindAllOccurrences(ByRef rangeToSearch As Range, ByRef textToFind As String, _
    Optional ByVal matchCaseOfText As Boolean = False, Optional ByVal matchCompleteText As Boolean = True) As Range

' returns a Range that contains all the cells in
' rangeToSearch that exactly match texToFind
' returns Nothing if no matches found
'
' Added parameters for matching case of text and matching complete text

Dim firstAddress As String
Dim cellFound As Range
Dim results As Range
Dim varLookAt As Variant

    If matchCompleteText Then
        varLookAt = xlWhole
    Else
        varLookAt = xlPart
    End If

    Set cellFound = rangeToSearch.Find(What:=textToFind, LookIn:=xlValues, LookAt:=varLookAt, MatchCase:=matchCaseOfText)
    If Not (cellFound Is Nothing) Then
        ' Have found textToFind at least once
        Set results = cellFound
        ' Store the address of the first result
        firstAddress = cellFound.Address
        Do
            Set cellFound = rangeToSearch.FindNext(After:=cellFound)
            If cellFound Is Nothing Then
                Exit Do
            Else
                ' Has the Find looped back to first cell?
                If cellFound.Address = firstAddress Then
                    Exit Do
                Else
                    Set results = Application.Union(results, cellFound)
                End If
            End If
        Loop
    End If

    Set FindAllOccurrences = results

End Function

And here is an example of using the function:

Sub ExampleCode()

Dim cellsFound As Range
Dim rangeToTest As Range

    Set rangeToTest = ThisWorkbook.Sheets(1).Range("A3:FU5002")

    Set cellsFound = FindAllOccurrences(rangeToTest, "Please Complete Image Template", True, True)
    ' If no matches are found, then cellsFound Is Nothing
    If Not (cellsFound Is Nothing) Then
        cellsFound.Interior.ColorIndex = 6
    End If

End Sub

Answer 3

This is a significant edit to the first method based on further testing, and feedback in the comment:

...first code was fast, but it clears/colors the first two rows that serve as my header for the sheet. Also the highlight "" doesn't detect cells with formulas that return a "" value

Also as a reference for other performance optimizations, considering that this functionality can be useful in a typical work environment:

1. Optimized "Last Cell" (my definition: the cell in lower-right corner of area containing data, regardless if this last cell contains data or not).
2. Functions to stop all GUI and events in Excel during VBA execution then turn all back On, including properties for each individual WorkSheet in current WB.
3. Reducing interaction with the WorkSheet object by applying cell color to a larger range with a string size of up to 255 characters ("A5,B7,D300,...,XFD100000") as opposed to applying it to each found cell.
4. Eliminating the call to SpecialCells(xlCellTypeBlanks) which took surprisingly long and ignored blank cells with formulas.
5. Optimized colLtr(fromColNumber) and colNum(fromColLtr) functions.
6. Use of Timers for performance measurements. A higher resolution timer is provide by Microsoft, through the use of API calls, for very fast operations: Measuring Calculation Time.
7. Improving a large set of test data with a relatively good mix of strings, numbers, blanks, and formulas for various scenarios.

Public Sub showItems()     '1 itm:   3.37 sec,  3.37 sec,  3.37 sec (numbers)
                           '1 itm:   6.04 sec,  6.04 sec,  6.02 sec (text)
                           '2 itms:  8.90 sec,  8.84 sec,  8.87 sec
                           '3 itms: 11.59 sec, 11.61 sec, 11.59 sec
                           '4 itms: 14.53 sec, 14.45 sec, 14.50 sec
                           '5 itms: 17.25 sec, 17.30 sec, 17.25 sec

    Const FIRST_CELL        As String = "A2"
    Const LAST_CELL         As String = ""  '"Z100000"
    Const SEARCH_ITEMS      As Long = 5
    Const ColorIndx_BLANK   As Long = 3
    Const ColorIndx_FOUND   As Long = 6

    Dim searchItems(1 To SEARCH_ITEMS) As String

    Dim ws As Worksheet:    Set ws = ThisWorkbook.Sheets(1)

    searchItems(1) = 337    '"Cell 1 Test"
    'searchItems(2) = 347
    'searchItems(3) = "Test Cell 25"
    'searchItems(4) = "7 Test Cell"
    'searchItems(5) = 335

    Dim dataRng     As Range
    Dim blank       As String:  Dim found       As String
    Dim cellStart   As Range:   Dim cellEnd     As Range
    Dim memArr      As Variant: Dim thisTxt     As Long
    Dim thisRow     As Long:    Dim thisCol     As Long
    Dim firstRow    As Long:    Dim firstCol    As Long
    Dim lastRow     As Long:    Dim lastCol     As Long
    Dim timeStart   As Double:  Dim timeEnd     As Double

    Set cellStart = ws.Range(FIRST_CELL)

    If Len(LAST_CELL) = 0 Or FIRST_CELL = LAST_CELL Then        'Last Cell
        Set cellEnd = getMaxCell(ws)
    Else
        Set cellEnd = ws.Range(LAST_CELL)
    End If

    If Not cellStart Is Nothing And Not cellEnd.Row > 1 Then

        With cellStart
            firstRow = .row
            firstCol = .Column
        End With
        With cellEnd
            lastRow = .row
            lastCol = .Column
        End With
        Set dataRng = ws.Range(cellStart, cellEnd)

timeStart = Timer   '------------------------------------------------------------------

        With dataRng
            .Interior.Pattern = xlNone      'all cells transparent
fastWB True
            memArr = .Value2                'all data to array

            For thisTxt = 1 To SEARCH_ITEMS 'all search items
                If Len(searchItems(thisTxt)) > 0 Then
                    For thisRow = firstRow - firstRow + 1 To lastRow - firstRow + 1
                        For thisCol = firstCol - firstCol + 1 To lastCol - firstCol + 1
                            'blanks
                            If Len(memArr(thisRow, thisCol)) = 0 Then
                                blank = blank & colLtr(thisCol) & thisRow & ","
                                If Len(blank) > 245 Then                'max txt sz 255
                                    blank = Left(blank, Len(blank) - 1)
                                    .Range(blank).Interior.ColorIndex = ColorIndx_BLANK
                                    blank = vbNullString
                                End If
                            'search for text
                            ElseIf memArr(thisRow, thisCol) = searchItems(thisTxt) Then
                                found = found & colLtr(thisCol) & thisRow & ","
                                If Len(found) > 245 Then
                                    found = Left(found, Len(found) - 1)
                                    .Range(found).Interior.ColorIndex = ColorIndx_FOUND
                                    found = vbNullString
                                End If
                            End If
                        Next
                    Next
                End If
            Next

            If Len(blank) > 0 Then  'last blanks
                blank = Left(blank, Len(blank) - 1)
                .Range(blank).Interior.ColorIndex = ColorIndx_BLANK
            End If

            If Len(found) > 0 Then  'last matches found
                found = Left(found, Len(found) - 1)
                .Range(found).Interior.ColorIndex = ColorIndx_FOUND
            End If

        End With
    End If
fastWB False
timeEnd = Timer     '------------------------------------------------------------------

    InputBox SEARCH_ITEMS & " items.   Duration:", "Find", timeEnd - timeStart & " sec"

End Sub

---

Public Sub FastWB(Optional ByVal opt As Boolean = True)
    With Application
        .Calculation = IIf(opt, xlCalculationManual, xlCalculationAutomatic)
        .DisplayAlerts = Not opt
        .DisplayStatusBar = Not opt
        .EnableAnimations = Not opt
        .EnableEvents = Not opt
        .ScreenUpdating = Not opt
    End With
    FastWS , opt
End Sub
Public Sub FastWS( _
                    Optional ByVal ws As Worksheet = Nothing, _
                    Optional ByVal opt As Boolean = True)
    If ws Is Nothing Then
        For Each ws In Application.ActiveWorkbook.Sheets
            EnableWS ws, opt
        Next
    Else
        EnableWS ws, opt
    End If
End Sub
Private Sub EnableWS(ByVal ws As Worksheet, ByVal opt As Boolean)
    With ws
        .DisplayPageBreaks = False
        .EnableCalculation = Not opt
        .EnableFormatConditionsCalculation = Not opt
        .EnablePivotTable = Not opt
    End With
End Sub

---

Public Function ColLtr(ByVal fromNum As Long) As String     'column letter from number

    'maximum number of columns: 16384 ("XFD")

    Const MAX_COLUMNS   As Integer = 16384

    If fromNum > 0 And fromNum <= MAX_COLUMNS Then

        Dim indx As Long, cond As Long

        For indx = Int(Log(CDbl(25 * (CDbl(fromNum) + 1))) / Log(26)) - 1 To 0 Step -1

            cond = (26 ^ (indx + 1) - 1) / 25 - 1

            If fromNum > cond Then
                ColLtr = ColLtr & Chr(((fromNum - cond - 1) \ 26 ^ indx) Mod 26 + 65)
            End If
        Next indx

    Else
        ColLtr = 0
    End If

End Function

Public Function ColNum(ByVal fromLtr As String) As Long     'column number from letter

    'A to XFD (16384); upper or lower case; if parameter is invalid it returns 0

    Const MAX_LEN       As Byte = 4
    Const LTR_OFFSET    As Byte = 64
    Const TOTAL_LETTERS As Byte = 26
    Const MAX_COLUMNS   As Integer = 16384

    Dim paramLen        As Long
    Dim tmpNum          As Integer

    paramLen = Len(fromLtr)
    tmpNum = 0

    If paramLen > 0 And paramLen < MAX_LEN Then
        Dim i           As Integer
        Dim tmpChar     As String
        Dim numArr()    As Integer

        fromLtr = UCase(fromLtr)
        ReDim Preserve numArr(paramLen)

        For i = 1 To paramLen
            tmpChar = Asc(Mid(fromLtr, i, 1))
            If tmpChar < 65 Or tmpChar > 90 Then Exit Function
            numArr(i) = tmpChar - LTR_OFFSET
        Next

        Dim highPower   As Integer
        highPower = UBound(numArr()) - 1

        For i = 1 To highPower + 1
            tmpNum = tmpNum + (numArr(i) * (TOTAL_LETTERS ^ highPower))
            highPower = highPower - 1
        Next
    End If

    If tmpNum < 0 Or tmpNum > MAX_COLUMNS Then tmpNum = 0

    ColNum = tmpNum

End Function

---

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell containing a value, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                        After:=.Cells(1, 1), _
                                        SearchDirection:=xlPrevious, _
                                        SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                            After:=.Cells(1, 1), _
                                            SearchDirection:=xlPrevious, _
                                            SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

For tests I used a Range from "A1" to "Z100,000" with row 1 as header:

The next solution doesn't align with OP's requirements (15.83 seconds):

Public Sub SortNColor()

    Const TOTAL_SEARCHES    As Long = 20

    Dim searchItems(1 To TOTAL_SEARCHES)    As Variant
    Dim sortColors(1 To TOTAL_SEARCHES)     As Long

    Dim searchSheet     As Worksheet
    Dim textItem        As Long
    Dim foundRange      As Range

    Dim cellStart       As Range
    Dim cellEnd         As Range

    Dim memArray        As Variant
    Dim thisTxt         As Long
    Dim timerStart      As Double
    Dim timerEnd        As Double

    Dim thisRow         As Long:    Dim thisCol         As Long

    Dim plageStart      As Range:   Dim filterStart     As Range
    Dim plageEnd        As Range:   Dim filterEnd       As Range
    Dim plageFirstRow   As Long:    Dim filterFirstRow  As Long
    Dim plageFirstCol   As Long:    Dim filterFirstCol  As Long
    Dim plageLastRow    As Long:    Dim filterLastRow   As Long
    Dim plageLastCol    As Long:    Dim filterLastCol   As Long



    timerStart = Timer

                    'Split(search text, .Interior.ColorIndex)
    searchItems(1) = Split("btty, 20", ", ")
    searchItems(2) = Split("clfn, 19", ", ")
    searchItems(3) = Split("chdr, 24", ", ")
    searchItems(4) = Split("dskp, 15", ", ")
    searchItems(5) = Split("flrp, 16", ", ")
    searchItems(6) = Split("flmt, 18", ", ")
    searchItems(7) = Split("lslt, 35", ", ")
    searchItems(8) = Split("pdt, 50", ", ")
    searchItems(9) = Split("pstt, 36", ", ")
    searchItems(10) = Split("rcdl, 37", ", ")
    searchItems(11) = Split("smflmt, 38", ", ")
    searchItems(12) = Split("tblp, 39", ", ")
    searchItems(13) = Split("trklt, 40", ", ")
    searchItems(14) = Split("vty, 20", ", ")
    searchItems(15) = Split("wsc, 42", ", ")
    searchItems(16) = Split("ocf, 43", ", ")
    searchItems(17) = Split("oflmt, 44", ", ")
    searchItems(18) = Split("opnt, 33", ", ")
    searchItems(19) = Split("osmflmt, 32", ", ")
    searchItems(20) = Split("owsc, 46", ", ")

    sortColors(1) = RGB(204, 255, 255)
    sortColors(2) = RGB(255, 255, 204)
    sortColors(3) = RGB(204, 204, 255)
    sortColors(4) = RGB(192, 192, 192)
    sortColors(5) = RGB(128, 128, 128)
    sortColors(6) = RGB(153, 51, 102)
    sortColors(7) = RGB(204, 255, 204)
    sortColors(8) = RGB(51, 153, 102)
    sortColors(9) = RGB(255, 255, 153)
    sortColors(10) = RGB(153, 204, 255)
    sortColors(11) = RGB(255, 153, 204)
    sortColors(12) = RGB(204, 153, 255)
    sortColors(13) = RGB(255, 204, 153)
    sortColors(14) = RGB(51, 204, 204)
    sortColors(15) = RGB(153, 204, 0)
    sortColors(16) = RGB(255, 204, 0)
    sortColors(17) = RGB(0, 204, 255)
    sortColors(18) = RGB(0, 0, 255)
    sortColors(19) = RGB(255, 102, 0)
    sortColors(20) = RGB(255, 0, 0)

    Set searchSheet = ThisWorkbook.Sheets(1)
    With searchSheet
        Set plageStart = .Range("G3")
        Set plageEnd = .Range("G100000")
        Set filterStart = .Range("A1")
        Set filterEnd = .Range("Z100000")
    End With

    With plageStart
        plageFirstRow = .Row
        plageFirstCol = .Column
    End With
    With plageEnd
        plageLastRow = .Row
        plageLastCol = .Column
    End With

    With filterStart
        filterFirstRow = .Row
        filterFirstCol = .Column
    End With
    With filterEnd
        filterLastRow = .Row
        filterLastCol = .Column
    End With



    'plage - colors

    With searchSheet

        .Cells.Interior.Pattern = xlNone

Application.ScreenUpdating = False

        memArray = .Range(plageStart, plageEnd)

        For thisTxt = 1 To TOTAL_SEARCHES
            For thisRow = plageFirstRow - plageFirstRow + 1 To plageLastRow - plageFirstRow + 1
                If memArray(thisRow, 1) = searchItems(thisTxt)(0) Then
                    .Range(.Cells(thisRow, 1), .Cells(thisRow, filterLastCol)). _
                        Interior.ColorIndex = searchItems(thisTxt)(1)
                End If
            Next
        Next
    End With



    'sorting - colors

    Dim rng As Range

    'For Each rng In searchSheet.Range(filterStart, filterEnd).Columns

    Set rng = searchSheet.UsedRange.Columns(1)

        With searchSheet.Sort
            With .SortFields
                .Clear
                For thisTxt = 1 To TOTAL_SEARCHES
                    .Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
                    SortOnValue.Color = sortColors(thisTxt)
                    DoEvents
                Next
            End With
            .SetRange searchSheet.UsedRange
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

    'Next

Application.ScreenUpdating = True

    timerEnd = Timer

    InputBox "Total Duration", "Total Duration", timerEnd - timerStart & " seconds"

End Sub