VBA to Transpose Rows to Columns

BoyBoy

New Member
Joined
Sep 25, 2020
Messages
26
Office Version
  1. 365
Platform
  1. Windows
Hi,
I need a vba code to rearrange (transpose) my data
from the following in sheet 1
1601016797022.png

to the following in sheet 2
1601016983766.png

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

Boyboy
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

drsarao

Well-known Member
Joined
Sep 9, 2009
Messages
1,141
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,365
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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

Well-known Member
Joined
Mar 22, 2015
Messages
614
Office Version
  1. 2013
Platform
  1. Windows
May Be

VBA Code:
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,365
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You can get rid of the loop like
VBA Code:
       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
 

BoyBoy

New Member
Joined
Sep 25, 2020
Messages
26
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

New Member
Joined
Sep 25, 2020
Messages
26
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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.
1601046815542.png


1601046881603.png
 

Attachments

  • 1601046873496.png
    1601046873496.png
    2 KB · Views: 0

BoyBoy

New Member
Joined
Sep 25, 2020
Messages
26
Office Version
  1. 365
Platform
  1. Windows
May Be

VBA Code:
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:
1601047364215.png

1601047384718.png
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,365
Office Version
  1. 365
Platform
  1. Windows
How about
VBA Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,114,421
Messages
5,547,823
Members
410,813
Latest member
Vhinzvirgo
Top