Option Explicit

Sub qqq()
    Dim x As Range, y As Range
    
    Sheets("List1").Select
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set x = Range("B4:B10000")
    x.Offset(1, 3).Resize(x.Rows.Count - 1, 1).ClearContents
    x.AutoFilter Field:=1, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
    Set y = x.Offset(1, 0).Resize(x.Rows.Count - 1, 1).SpecialCells(12)
    y.Copy
    [E5].PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    ActiveSheet.AutoFilterMode = False
    y.ClearContents
    y.Interior.ColorIndex = xlNone
    x.Sort x.Cells(1), Header:=xlYes
    x.Offset(0, 4).Sort x.Cells(1).Offset(0, 4), Header:=xlYes
    Range("E5").Select
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

x.Offset(0, 4).Sort x.Cells(1).Offset(0, 4), Header:=xlYes

x.Offset(0, 3).Sort x.Cells(1).Offset(0, 3), Header:=xlYes

Sub ww()
    Dim a As Object, b As Object, c As Variant, d As Object, r As Range
    Set a = CreateObject("scripting.dictionary")
    Set b = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = 0: Application.EnableEvents = 0
    With [Лист1!B5]
        With Range(.Cells, .End(xlDown)).Resize(, 4)
            For Each r In .Rows
                For Each c In Array(1, 4)
                    With r.Cells(1, c)
                        If Not IsEmpty(.Value) Then IIf(.Interior.Color = vbYellow, b, a)(.Value) = 0
                    End With
            Next c, r
            For Each c In Array(1, 4)
                Set d = IIf(c = 1, a, b)
                With .Columns(c)
                    .ClearContents
                    .Interior.Color = xlNone
                    With .Resize(d.Count)
                        .Value = Application.Transpose(BubbleSort(d.keys))
                        If c <> 1 Then .Interior.Color = vbYellow
                    End With
                End With
            Next
        End With
    End With
    Set a = Nothing: Set b = Nothing: Set d = Nothing
    Application.ScreenUpdating = 1: Application.EnableEvents = 1
End Sub
Private Function BubbleSort(v As Variant) As Variant
    Dim i&, j&
    For i = LBound(v) To UBound(v) - 1: For j = i To UBound(v)
        Swap v(i), v(j)
    Next j, i
    BubbleSort = v
End Function
Private Sub Swap(ByRef a As Variant, ByRef b As Variant)
    If a > b Then: Dim c: c = a: a = b: b = c
End Sub