MultiLevel Sort till end column

Hi,

I am having difficulty on the macro to do multilevel sort by color.

Criteria
- Sort each column that have highlighted till end column (this can be about 40 columns and 500 rows data)
- Ignore the column that no highlighted cell
- Keep the information align when sort across column and row

Below is the VB that tried to develop but seems not working as expected. Attached is sample data Before and After in sheet1. I have done manual by custom sort.

Sub MultiSort)
    Dim xRg As Range 'Declare range for Columns
    Dim yRg As Range 'Declare range for Rows
    Dim ws As Worksheet 'Name the WorkSheet
    Set ws = ActiveSheet
    On Error Resume Next
    Set xRg = Application.InputBox(Prompt:="Range Selection:", _
                                    Title:="Sort Multiple Columns", Type:=8)
    Application.ScreenUpdating = False
    For Each yRg In xRg
        With ws.Sort
            .SortFields.Clear
            .SortFields.Add(Key:=yRg, Order:=xlAscending, _
             SortOn:=xlSortOnCellColor).SortOnValue.Color = vbGreen
            .SetRange ws.Range(yRg, yRg.End(xlDown))
            .Header = xlNo
            .MatchCase = False
            .Apply
        End With
    Next yRg
    Application.ScreenUpdating = True
End Sub