Excel formula to manage output orientation

[SmallJack]

Hi Gurus,

Would need your kind expertise to help on this request.

Assuming I’ve the following sample data and wishing if the output data could be formatted using some excel formulas, refer to below sample.

Sample data (Sheet1):
StudentA | Lesson1
StudentA | Lesson21
StudentA | Lesson10
StudentA | Lesson5
StudentB | Lesson5
StudentB | Lesson6
StudentC | Lesson9
StudentC | Lesson8
StudentC | Lesson9
StudentC | Lesson15
StudentC | Lesson11
StudentC | Lesson30
StudentC | Lesson13
StudentD | Lesson1
StudentD | Lesson2
StudentD | Lesson3
StudentD | Lesson4
StudentD | Lesson5
StudentD | Lesson6
StudentD | Lesson7
StudentD | Lesson8

Sample output (Sheet2):
StudentA | StudentB | StudentC | StudentD
Lesson1 | Lesson5 | Lesson9 | Lesson1
Lesson21 | Lesson6 | Lesson8 | Lesson2
Lesson10..................Lesson9 | Lesson3
Lesson5....................Lesson15 | Lesson4
.................................Lesson11 | Lesson5
.................................Lesson30 | Lesson6
.................................Lesson13 | Lesson7
..................................................Lesson8

The sample data could be long and a lot, so it's best if the formula can be made flexible to cater for this requirement.

Please refer to the attached file for some sample data.

Appeciate for any of your help and advice.

Thank you a lot in advance.


Regards,
Jack

[rylo]

Hi

No workbook attached, but if your data starts in A1 in sheet1, then the following should break it out onto sheet2.

Sub aaa()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  OutSH.Cells.ClearContents
  For Each ce In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If WorksheetFunction.CountIf(Range("A1:A" & ce.Row), ce.Value) = 1 Then
      OutSH.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = ce.Value
    End If
    outcol = WorksheetFunction.Match(ce.Value, OutSH.Rows("1:1"), 0)
    OutSH.Cells(Rows.Count, outcol).End(xlUp).Offset(1, 0).Value = ce.Offset(0, 1).Value
  Next ce
  OutSH.Columns("A:A").Delete
End Sub

HTH

rylo

[SmallJack]

Hi rylo,

Thanks for your response.

I guess I might have missed out the attachment file earlier. Had already upload it.

I've tried your script, but hit an error when I tried to execute it.

The error is referring to undefined variable.

Please kindly help to check and advice.

Thanks a lot.


Regards,
Jack.

[JBeaucaire]

This macro will alphabetize the student roster, if it's not already, and uses a "one pass per student" loop that should be peppy on larger data sets since you're not going cell by cell. Also, your sample didn't show data in row1, so mine adds a title row. We can delete that if there are titles already.

Sub ReorganizeStudents()
Dim LC As Long, i As Long, wsOut As Worksheet
Application.ScreenUpdating = False
Set wsOut = Sheets("Sheet2")

Rows(1).Insert xlShiftDown
Range("A1") = "key"

Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
Range("AA:AA").Sort Key1:=Range("AA2"), Order1:=xlAscending, Header:=xlYes, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("AA2:AA" & Rows.Count).SpecialCells(xlCellTypeConstants).Copy
wsOut.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Range("AA:AA").Clear

LC = wsOut.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To LC
    Range("A:A").AutoFilter 1, wsOut.Cells(1, i)
    Range("B2", Range("B2").End(xlDown)).Copy wsOut.Cells(2, i)
Next i

ActiveSheet.AutoFilterMode = False
Rows(1).Delete xlShiftUp
wsOut.Activate
Application.ScreenUpdating = True
End Sub

How/Where to install the macro:

1. Open up your workbook
2. Get into VB Editor (Press Alt+F11)
3. Insert a new module (Insert > Module)
4. Copy and Paste in your code (given above) to this new module
5. Get out of VBA (Press Alt+Q)
6. Save your sheet

The macro is installed and ready to use. Press Alt-F8 and select it from the macro list.

Will create the list on Sheet2. Works well on your sample sheet.

[SmallJack]

Hi JBeaucaire,

Thanks a lot for your response and help.

I've tested your formula and it works perfectly.

If there is no more issues, I will close the post.

Have a nice day.


Regards,
Jack.

[rwgrietveld]

If you don't want the VBA then try a Pivot table.

1) First add headings to student and Lessons
Like
Student | Lesson
StudentA | Lesson 1
2) Make a pivot Table
Column: Student
Row: Lessons
Values: Lessons (Standard count)
3) Use this formula =IF(B5<>"",$A5,"") to change the values (1,2,3) into Lessons

[SmallJack]

Hi Ricardo,

Thanks a lot for your response.

I will check and test your method.


Regards,
Jack

[SmallJack]

Dear All,

Would like to thank you for your value contribution to my query.

It's certainly helped me solving my issue.


Regards,
Jack

[pike]

Hi smalljack
Its best to just post a question and not pm as I have been away this week
The "Scripting.Dictionary" code would be....

Sub testp()
    Dim a, b(), i As Long, n As Long, z As Long, y As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
        With CreateObject("Scripting.Dictionary")
            .CompareMode = vbTextCompare
            For i = 1 To UBound(a, 1)
                a(i, 1) = Trim(a(i, 1))
                If Not IsEmpty(a(i, 1)) Then
                    If Not .exists(a(i, 1)) Then
                        z = 2
                        n = n + 1
                        b(1, n) = a(i, 1)
                        .Add a(i, 1), n
                    End If
                    b(.Item(a(i, 1)) + z - n, n) = a(i, 2)
                    z = z + 1
                    y = IIf(z > y, z, y)
                End If
            Next
            z = 0
        End With
    End With
    Sheets("sheet2").Range("a1").Resize(n + 1, y).Value = b
End Sub

[pike]

or even better for unsorted lists
using the dic will be the fastest

Option Explicit
Sub testp()
    Dim a, b(), i As Long, n As Long, z As Long, y As Long, Dict1 As Object, Dict2 As Object, p As Long
    With Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(, 2)
        a = .Value
        ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1))
        Set Dict1 = CreateObject("Scripting.Dictionary")
        Set Dict2 = CreateObject("Scripting.Dictionary")
        With Dict1
            .CompareMode = vbTextCompare
            For i = 1 To UBound(a, 1)
                a(i, 1) = Trim(a(i, 1))
                If Not IsEmpty(a(i, 1)) Then
                    If Not .exists(a(i, 1)) Then
                        p = 2: n = n + 1
                        b(1, n) = a(i, 1)
                        .Add a(i, 1), n
                        With Dict2
                            .Add a(i, 1), p
                        End With
                    End If
                    b(Dict2.Item(a(i, 1)), .Item(a(i, 1))) = a(i, 2)
                    With Dict2
                        If .exists(a(i, 1)) Then
                            .Item(a(i, 1)) = .Item(a(i, 1)) + 1
                        End If
                    End With
                    y = IIf(Dict2.Item(a(i, 1)) > y, Dict2.Item(a(i, 1)), y)
                End If
            Next
        End With
    End With
    Sheets("sheet2").Range("A1").Resize(y, n).Value = b
End Sub

[SmallJack]

Hi All,

Sorry for late response as I've been away for quite some times.

Thanks a lot for all of your help.


- Jack

[snb]

or

Sub tst()
    on error resume next
    sq = ThisWorkbook.Sheets("Sheet1").UsedRange
    For j = 1 To UBound(sq)
        c01 = c01 & vbCr & sq(j, 1) & "|" & sq(j, 2)
    Next

    sq = Split(Mid(c01, 2), vbCr)
    sn = Filter(sq, Split(sq(0), "|")(0))

    Do
        With ThisWorkbook.Sheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Offset(1, 1).Resize(UBound(sn) + 1)
            .Value = WorksheetFunction.Transpose(sn)
            .Replace Split(sn(0), "|")(0) & "|", ""
            .Resize(1).Offset(-1) = Split(sn(0), "|")(0)
        End With
        sq = Filter(sq, Split(sn(0), "|")(0), False)
        sn = Filter(sq, Split(sq(0), "|")(0))
    Loop Until UBound(sq) = -1
End Sub

[SmallJack]

Hi Gurus,

Sorry to update my old post article.

My data has grown much bigger now and when I tried to use the same formula provided by "pike" with dict function, the same formula is unable to process the whole data.

I've more than 4000 rows now with different combination, after running the formula, it stopped at column IV.

Anybody can help?

Thanks.