VBA to Transpose Rows to Columns

[BoyBoy]

Hi,
I need a vba code to rearrange (transpose) my data
from the following in sheet 1

to the following in sheet 2

My column A (Class Name) has more than 10,000 rows.
A working code would be greatly appreciated.

Boyboy

 

[drsarao]

Are there only 4 classes - ClassA to ClassD?
Are class students grouped together class-wise as shown in sample? Or randomly listed.
How many students in each class? 10,000 row would suggest 2,500 students in 4 classes!
Do you need the transposed list of students in alphabetical order?
Post a sample data using Excel addin XL2bb provided by MrExcel at XL2BB - Excel Range to BBCode

 

[Fluff]

How about

Sub BoyBoy()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long, nnr As Long, c As Long, Mx As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary))
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), Array(nr, 3)
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
         Else
            nnr = .Item(Ary(r, 1))(0)
            c = .Item(Ary(r, 1))(1)
            If c > Mx Then Mx = c
            Nary(nnr, c) = Ary(r, 2)
            .Item(Ary(r, 1)) = Array(nnr, c + 1)
         End If
      Next r
   End With
   Sheets("Sheet2").Range("A2").Resize(nr, Mx).Value = Nary
End Sub

 

[mohadin]

May Be

Sub test()
    Dim a As Variant
    Dim i
    a = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .Exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                End If
            End If
        Next
       Sheet2.Select
       Cells(2, 1).Resize(.Count) = Application.Transpose(.keys)
        For i = 1 To .Count
          Sheets("Sheet2").Cells(i + 1, 2).Resize(, UBound(Split(.Items()(i - 1), ",")) + 1) = Split(.Items()(i - 1), ",")
        Next
      End With
End Sub

 

[Fluff]

You can get rid of the loop like

       Cells(2, 1).Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
       Cells(2, 2).Resize(.Count).TextToColumns Cells(2, 2), xlDelimited, , , 0, 0, 1, 0, 0

 

[mohadin]

 

[BoyBoy]

Are there only 4 classes - ClassA to ClassD?
Are class students grouped together class-wise as shown in sample? Or randomly listed.
How many students in each class? 10,000 row would suggest 2,500 students in 4 classes!
Do you need the transposed list of students in alphabetical order?
Post a sample data using Excel addin XL2bb provided by MrExcel at XL2BB - Excel Range to BBCode

My project has more than 4 classes, the example I provided above, was just part of the data.
The classes and students are not divided equally, if the result can be sorted it by alphabetical order, then great, but it doesn't have to be in order.

Thanks in advance for your help.
BoyBoy

 

[BoyBoy]

How about

Sub BoyBoy()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long, nnr As Long, c As Long, Mx As Long
  
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To UBound(Ary))
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), Array(nr, 3)
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
         Else
            nnr = .Item(Ary(r, 1))(0)
            c = .Item(Ary(r, 1))(1)
            If c > Mx Then Mx = c
            Nary(nnr, c) = Ary(r, 2)
            .Item(Ary(r, 1)) = Array(nnr, c + 1)
         End If
      Next r
   End With
   Sheets("Sheet2").Range("A2").Resize(nr, Mx).Value = Nary
End Sub

Thanks so much, however I've got this error while running it.

 

[BoyBoy]

May Be

Sub test()
    Dim a As Variant
    Dim i
    a = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 2)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) <> 0 Then
                If Not .Exists(a(i, 1)) Then
                    .Add a(i, 1), a(i, 2)
                Else
                    .Item(a(i, 1)) = .Item(a(i, 1)) & "," & a(i, 2)
                End If
            End If
        Next
       Sheet2.Select
       Cells(2, 1).Resize(.Count) = Application.Transpose(.keys)
        For i = 1 To .Count
          Sheets("Sheet2").Cells(i + 1, 2).Resize(, UBound(Split(.Items()(i - 1), ",")) + 1) = Split(.Items()(i - 1), ",")
        Next
      End With
End Sub

Thank you so much.
However it gave me this error:

 

[Fluff]

How about

Sub BoyBoy()
   Dim Ary As Variant
   Dim r As Long
  
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         .Item(Ary(r, 1)) = .Item(Ary(r, 1)) & Ary(r, 2) & "|"
      Next r
      Sheets("sheet2").Range("A2").Resize(.Count, 2).Value = Application.Transpose(Array(.Keys, .Items))
      Sheets("sheet2").Range("B:B").TextToColumns Range("b1"), xlDelimited, , , 0, 0, 0, 0, 1, "|"
   End With
   With Sheets("Sheet2")
      .Range("A1:B1").Value = Array("Class Name", "Student Name 1")
      .Range("B1").AutoFill .Range("B1").Resize(, .Range("A1").CurrentRegion.Columns.Count - 1)
      .Range("A2").CurrentRegion.Sort .Range("A2"), xlAscending, , , , , , xlYes
   End With
End Sub