Microsoft Office Forums - View Single Post - Need help sorting data in columns that will sort by number of Xs

jolivanes · 04-06-2014, 02:02 PM

Or try this (on a copy of your workbook)
When you copy it into another workbook, change the Sheet references as required.

Code:

 
Sub Try_This()
    Dim lc As Long, lr As Long, i As Long, c As Range
    lc = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.ScreenUpdating = False
    With Range(Cells(1, 1), Cells(lr, lc))
        .SpecialCells(4).Delete -4162
    End With
    For i = 1 To lc
        Cells(i, lc + 1).Value = ActiveSheet.Cells(Rows.Count, i).End(xlUp).Row
        Cells(i, lc + 2).Value = i
    Next i
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(1, lc + 1), Cells(lc, lc + 1)), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Cells(1, lc + 1), Cells(lc, lc + 2))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    i = 1
    For Each c In Range(Cells(1, lc + 2), Cells(1, (lc + 2)).End(xlDown))
        Range(Cells(1, c.Value), Cells(1, c.Value).End(xlDown)).Copy Cells(lr + 2, i)
        i = i + 1
    Next c
    Rows("1:" & lr + 1).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub