VBA/Macros - sorting across multiple repetitive columns

[almugs]

Good day. Hopefully someone can help with this? I have attached an example spreadsheet with two tabs. The first tab (Matrix) shows raw data scores - there are 28 measures in Column A and Participants in Row 1. There are always 28 measures but participants can vary. What I need to happen is to sort each measure in a Lineup tab i.e. rank all the participants listed in the Matrix tab from lowest score to highest score for each of the 28 measures. Obviously this can be done manually but a VBA/macro solution will be so much faster and easier. Unfortunately I have to keep the data in this format so the macro will need to transpose the data to get into the formt in the Lineup tab. Thanks for you assistance.

test.xlsx

[PCI]

See next code

Option Explicit

Sub LineUp()
Dim LastRow  As Long
Dim I   As Long, K   As Long
Dim WkRg As Range
    Application.ScreenUpdating = False
    Sheets("Lineup").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    K = 1
    With Worksheets("Matrix")
        .Range("A1").CurrentRegion.Copy
        .Range("P1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
    
        .Range("P1").CurrentRegion.AutoFilter
        LastRow = .Range("P" & Rows.Count).End(xlUp).Row
        For I = 1 To 28
            Set WkRg = .Range("P1").Offset(, I).Resize(LastRow)
            With .AutoFilter.Sort.SortFields
                .Clear
                .Add Key:=WkRg, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
            End With
            With .AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            Union(.Range("P1").Resize(LastRow), WkRg).Offset(1, 0).Copy Destination:=Sheets("Lineup").Range("A2").Offset(0, K - 1)
            K = K + 2
        Next I
        .Columns("P:AT").Delete Shift:=xlToLeft
    End With
    
    With Sheets("Lineup").Range("A1").CurrentRegion.Offset(1, 0)
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext

        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    Application.ScreenUpdating = True
 End Sub

[almugs]

Sorry for the delay in getting back to you. This looks very good and works well with this data set. However, I sometimes have to use quite large data sets i.e. over 1,000 participants. Is it possible to design the code to take into account such a large number of participants? I think currently this code only analyses 15 participants which is probably due to fact that the transpose element of the code uses Columns P:AT. Could we solve this by creating another tab e.g. Transpose where this data can be copied to instead of using the Matrix tab?

[xladept]

Hi almugs,

I've been going nuts trying to find this post - I found it by searching "28 measures" (almugs didn't work) - well, anyway, try this:

Sub Almugs(): Dim wm As Worksheet, wl As Worksheet, Lineup As Range
Dim r As Long, c As Long, M, L, n As Integer, k As Long
Set wm = Sheets("Matrix"): Set wl = Sheets("Lineup")
            M = wm.Cells(1).CurrentRegion: k = 1
L = wm.Range(wm.Cells(1, UBound(M, 2) + 1), wm.Cells(UBound(M), UBound(M, 2) + 2))
For r = 2 To UBound(M): n = 1

For c = 2 To UBound(M, 2)
L(n, 1) = M(1, c): L(n, 2) = (M(r, c)): n = n + 1
Next c

Set Lineup = wl.Range(wl.Cells(2, k), wl.Cells(UBound(M) + 1, k + 1)): Lineup = L
Lineup.Sort Key1:=wl.Cells(2, k + 1), Order1:=xlAscending, Header:=xlNo: k = k + 2

Next r
End Sub

[almugs]

Again very impressive. But still hasn't solved the additional problem when I have additional participants (which can be upto 500 and beyond) . I get the following message "Run Time Error "9" Subscript out of Range" when I have data in column AE and beyond (30 participants). Data upto column AD (29 participants seems to work fine).

test (2).xlsm

[PCI]

Try

Sub LineUp()
Dim LastRow  As Long
Dim I   As Long, K   As Long
Dim WkRg As Range
    Application.ScreenUpdating = False
    Sheets("Lineup").Range("A1").CurrentRegion.Offset(1, 0).ClearContents
    K = 1
    Worksheets("Matrix").Range("A1").CurrentRegion.Copy
    
    With Sheets("Lineup")
        .Range("CA1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
            False, Transpose:=True
    
        .Range("CA1").CurrentRegion.AutoFilter
        LastRow = .Range("CA" & Rows.Count).End(xlUp).Row
        For I = 1 To 28
            Set WkRg = .Range("CA1").Offset(, I).Resize(LastRow)
            With .AutoFilter.Sort.SortFields
                .Clear
                .Add Key:=WkRg, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
            End With
            With .AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            Union(.Range("CA1").Resize(LastRow), WkRg).Offset(1, 0).Copy Destination:=Sheets("Lineup").Range("A2").Offset(0, K - 1)
            K = K + 2
            
        Next I
        .Columns("CA:DH").Delete Shift:=xlToLeft
    End With
    
    With Sheets("Lineup").Range("A1").CurrentRegion.Offset(1, 0)
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext

        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    Application.ScreenUpdating = True
 End Sub

[xladept]

Hi Almugs,

Try this version:

Sub Almugs(): Dim wm As Worksheet, wl As Worksheet, Lineup As Range
Dim r As Long, c As Long, M, L, n As Integer, k As Long
Set wm = Sheets("Matrix"): Set wl = Sheets("Lineup")
            M = wm.Cells(1).CurrentRegion: k = 1
L = wm.Range(wm.Cells(1, 1), wm.Cells(UBound(M, 2), 2))
For r = 2 To UBound(M): n = 1

For c = 2 To UBound(M, 2)
L(n, 1) = M(1, c): L(n, 2) = (M(r, c)): n = n + 1
Next c

Set Lineup = wl.Range(wl.Cells(2, k), wl.Cells(UBound(M, 2), k + 1)): Lineup = L
Lineup.Sort Key1:=wl.Cells(2, k + 1), Order1:=xlAscending, Header:=xlNo: k = k + 2

Next r
End Sub

[almugs]

Brilliant. Thanks both for all your help with this. Both solutions work well now. However, xladept's solution appears to be much faster. I will do some more testing with bigger datasets but believe you have both cracked this.

[xladept]

Great! You're welcome!

[PCI]

xladept's solution is clearly faster.
If there is still speed issue some others possibilities exist but a bit longer to prepare