Solved: Horizontal Sorting

[maestro_01]

Hello,

I have a column I need to sort horizontally. The catch? It is grouped by a category in the adjacent column so for example:

A,1
A,2
A,3
B,4
B,5

Will need to be:

A,1,2,3
B,4,5

How would I go about doing this?

Thanks

[GTO]

Greetings,

Your sample data only shows transposing by category. Does there need to be a Sort as well?

[maestro_01]

Thanks GTO,

Not exactly Transpose, transpose would make column A-row 1 and column B-row 2. I would still need to keep column A, but horizontal sort column B based on the values in column A.

[GTO]

Maybe I am being more thick-headed than usual, but I am still not following exactly. "horizontal sort column B...." makes no sense.

Please attach a workbook. On Sheet1 list the data how it should look 'Before' and 'After' on another sheet.

In the 'Before' view, please don't have stuff listed 1,2,3, A,B,C, but random. This way, we could tell what the sort is actually supposed to do.

Thanks,

Mark

[maestro_01]

Thanks GTO - much appreciated.

Please see attached, I named sheet 1 "Before Sort" and sheet 2 is named "After".

[GTO]

In a Standard Module:

Option Explicit
    
Sub exa()
Dim _
rngData                 As Range, _
aCats                   As Variant, _
CatVal                  As Variant, _
aryOutput               As Variant, _
i                       As Long, _
ii                      As Long, _
x                       As Long, _
blnEmptySlotExists      As Boolean
    
'// change first/top row to suit//
Const FIRST_ROW As Long = 1
    
    '//     Set a reference to the first column / the categories                        //
    With Sheet1 'ThisWorkbook.Worksheets("BEFORE SORT")
        Set rngData = .Range(.Cells(FIRST_ROW, "A"), .Cells(.Rows.Count, "A").End(xlUp))
    End With
    
    '// Fill a 1 to x by 1 to 1 array with the values.                                  //
    aCats = rngData.Value
    
    '// Create a Dictionary and ...                                                     //
    With CreateObject("Scripting.Dictionary")
        '// ...fill it with unique values from the first column.  We will use this      //
        '// collection to tack in values belonging to each category.                    //
        For Each CatVal In aCats
            .Item(Key:=CatVal) = Empty
        Next
        
        '// Initially change our collection of categeories into an array where the      //
        '// first column holds the category names.                                      //
        aryOutput = Application.Transpose(.Keys)
        
        '// Re-use aCats to now hold both columns values.                               //
        aCats = rngData.Resize(, 2).Value
        
        '// .Count will be the same as UBound(aryOutput, 1).  Outer loop runs thru our  //
        '// collection...                                                               //
        For i = 1 To .Count
            '// ...inner loop runs thru first column...                                 //
            For ii = LBound(aCats, 1) To UBound(aCats, 1)
                '// ...and if the cell matches the current item in the first column of  //
                '// our aoutput array...                                                //
                If aCats(ii, 1) = aryOutput(i, 1) Then
                    '// then we run thru the columns in the correct row of the array, to//
                    '// see if we have an empty element.                                //
                    For x = 1 To UBound(aryOutput, 2)
                        If IsEmpty(aryOutput(i, x)) Then
                            '// If we find an empty element, tack in the val there.     //
                            aryOutput(i, x) = aCats(ii, 2)
                            blnEmptySlotExists = True
                            Exit For
                        End If
                    Next
                    
                    '// If we didn't find an empty element, we need to resize the array //
                    '// to hold the match.                                              //
                    If Not blnEmptySlotExists Then
                        ReDim Preserve aryOutput(1 To .Count, 1 To UBound(aryOutput, 2) + 1)
                        aryOutput(i, UBound(aryOutput, 2)) = aCats(ii, 2)
                    Else
                        blnEmptySlotExists = False
                    End If
                End If
            Next
        Next
    End With
    
    '// plunk the output wherever...                                                    //
    With ThisWorkbook.Worksheets.Add(After:=rngData.Parent).Range("A2") _
            .Resize(UBound(aryOutput, 1), UBound(aryOutput, 2))
        
        .Value = aryOutput
        .EntireColumn.AutoFit
        .Parent.Name = "MY AFTER"
    End With
End Sub

Hoep that helps,

Mark

[maestro_01]

Thanks so much GTO, it sorts perfectly! I just have one more question, if the sorted data (the names) have conditional formatting based on data in other column, how would I be able to copy over the conditional formatting?

Thanks Again!