# VBA to Transpose Rows to Columns

#### BoyBoy

##### New Member
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

### 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
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
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
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``````

##### Well-known Member
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
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

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``````

##### Well-known Member #### BoyBoy

##### New Member

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.

BoyBoy

#### BoyBoy

##### New Member
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
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

##### New Member
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
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

##### MrExcel MVP, Moderator
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``````

Replies
11
Views
140
Replies
19
Views
250
Replies
3
Views
53
Replies
0
Views
54
Replies
0
Views
37