Sub Макрос1()

Dim lastcol&
Dim Shps()
Dim sp As Shape

    lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
    ReDim Shps(1 To lastcol - 1)
    For i = 1 To lastcol - 1
        Set Shps(i) = Cells(1, i + 1).Resize(8)
    Next i
    Call sort1(Shps)
    For i = 1 To lastcol - 1
        Set sp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, Shps(i)(2, 1), Shps(i)(3, 1), Shps(i)(5, 1), Shps(i)(6, 1))
        With sp.Fill
            .Visible = msoTrue
            .ForeColor.RGB = Shps(i)(7, 1).Interior.Color
            .Transparency = 0
        End With
        
    Next i
End Sub
Function sort1(Arr1 As Variant) As Variant
    Dim tmp
    For i = 1 To UBound(Arr1)
        For j = 1 To UBound(Arr1) - 1
            If (Arr1(j)(8, 1) > Arr1(j + 1)(8, 1)) Then
                tmp = Arr1(j)(8, 1)
                Arr1(j)(8, 1) = Arr1(j + 1)(8, 1)
                Arr1(j + 1)(8, 1) = tmp
            End If
        Next j
    Next i
    sort1 = Arr1
End Function

Function sort1(Arr1 As Variant)
    Dim tmp
    For i = 1 To UBound(Arr1)
        For j = 1 To UBound(Arr1) - 1
            If (Arr1(j)(8, 1) > Arr1(j + 1)(8, 1)) Then
                Set tmp = Arr1(j)
                Set Arr1(j) = Arr1(j + 1)
                Set Arr1(j + 1) = tmp
            End If
        Next j
    Next i
    sort1 = Arr1
End Function