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
 

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
   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:B2").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
Getting this error
1601048386826.png

and the result:
1601048858526.png
 

Some videos you may like

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,448
Office Version
  1. 365
Platform
  1. Windows
Did you copy/paste the code I supplied, or re-type?
Also did you make any changes to it?
 

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
   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:B2").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
I think we are almost there :)
The Class Name and the Student Name 1 are still repeating themselves in A2, B2, where I am expecting cell A2 to show "Class A", and cell B2 to show "Nancy"
1601049560424.png


The result I am looking for is
Class NameStudent Name1Student Name2Student Name3Student Name4Student Name5
ClassANancyLilyJohnKateWendy
ClassBJayAndyKelly
ClassCMandyJenniferNigelBruce
ClassDRobJohnny
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,448
Office Version
  1. 365
Platform
  1. Windows
Can you answer my questions in post#12
 

BoyBoy

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

ADVERTISEMENT

Can you answer my questions in post#12
Oops, sorry, I was using my own example to run the code, and I didn't change anything...
However, I think I got the problem fixed in my example, by changing the
.Range("A1:B2").Value = Array("Class Name", "Student Name 1")
to .Range("A1:B1").Value = Array("Class Name", "Student Name 1")
Thanks so much for your help, greatly appreciated!

Have a nice day!
BoyBoy
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
48,448
Office Version
  1. 365
Platform
  1. Windows
Glad you sorted it & thanks for the feedback.
 

Dossfm0q

Active Member
Joined
Mar 9, 2009
Messages
403

ADVERTISEMENT

Greetings
what Abut Using Formula?

I think this will be help full for your Project


Thanks
VBA Code:
=IFERROR(INDEX($B$2:$B$16,AGGREGATE(15,6,(ROW($A$2:$A$16)-ROW($A$2)+1)/($A$2:$A$16=$D2),COLUMNS($A1:A1))),"")

Book1
ABCDEFGHIJKLMNO
1Class Name Student NameClass Name Student Name1 Student Name2Student Name3Student Name4Student Name5Student Name6Student Name7Student Name8Student Name9Student Name10Student Name11
2ClassANancy ClassANancy Lily Kate Wendy Jay Judy Nigel     
3ClassALily ClassBJohn Andy Kelly         
4ClassBJohn ClassCMandy Jennifer Bruce         
5ClassAKate ClassDRob Johnny          
6ClassAWendy
7ClassAJay
8ClassBAndy
9ClassBKelly
10ClassAJudy
11ClassCMandy
12ClassCJennifer
13ClassANigel
14ClassCBruce
15ClassDRob
16ClassDJohnny
Sheet2
Cell Formulas
RangeFormula
E2:O5E2=IFERROR(INDEX($B$2:$B$16,AGGREGATE(15,6,(ROW($A$2:$A$16)-ROW($A$2)+1)/($A$2:$A$16=$D2),COLUMNS($A1:A1))),"")
 
Last edited:

Dossfm0q

Active Member
Joined
Mar 9, 2009
Messages
403
Hi Below VBA to set up Formula and Format Conditions

Note i Face problem with
Code:
 =COUNTA($E$2:$E$5)
if ranges have formula


VBA Code:
Sub VBA_Add_Formula_to_Transpose_Rows_to_Columns()
Dim SurcSht As Worksheet, TrgtSht As Worksheet
Dim Rng As Range, SrctRng As Range, condRng As Range

'Set SurcSht = ThisWorkbook.Worksheets("Sheet2") 'change as you need
'Set TrgtSht = ThisWorkbook.Worksheets("Sheet3") 'change as you need
' or use ActiveSheet
Set SurcSht = ThisWorkbook.ActiveSheet
Set TrgtSht = ThisWorkbook.ActiveSheet

Set SrctRng = SurcSht.Range("B1:B" & SurcSht.Cells(Rows.Count, "B").End(xlUp).Row)
Set condRng = SurcSht.Range("A1:A" & SurcSht.Cells(Rows.Count, "A").End(xlUp).Row)
If SurcSht.Name = TrgtSht.Name Then SurcSht.Activate
StrtCl = 4 ' Column D as you want
StrtRw = 1 ' Row 1  as you want

SrcFC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(1, 1).Address
SrcSC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(2, 1).Address
SrcBC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & SrctRng.Cells(2, 1).Resize(SrctRng.Rows.Count - 1, 1).Address

codtFC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(1, 1).Address
codtSC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(2, 1).Address
codtBC = IIf(SurcSht.Name <> TrgtSht.Name, SurcSht.Name & "!", "") & condRng.Cells(2, 1).Resize(condRng.Rows.Count - 1, 1).Address

TrgtSht.Cells.FormatConditions.Delete
arr = Array("Class Name", "ClassA", "ClassB", "ClassC", "ClassD")
For i = 1 To 5
With TrgtSht.Cells(StrtRw - 1 + i, StrtCl)
.Value = arr(i - 1)

    For b = 7 To 10
    With .Borders(b)
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Next
If i = 1 Then
.Interior.Color = RGB(85, 135, 53)
Else
.Interior.Color = RGB(200, 225, 180)
End If
If i = 1 Then
.Font.Color = RGB(255, 255, 255)
.Font.Bold = True
Else
.Font.Color = RGB(0, 0, 0)
End If

End With
Next
For Each Rng In SrctRng
Rw = StrtRw + Rng.Column - SrctRng.Column
Cl = StrtCl + Rng.Row - SrctRng.Row

With TrgtSht.Cells(Rw, Cl + 1)
CntCL = Cells(StrtRw, StrtCl + 1).Address & ":" & .Address(False, False)
.Value = "=IF(COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0," & SrcFC & "&COLUMNS(" & CntCL & "),"""")"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Font
        .Bold = True
        .Italic = False
        .TintAndShade = 0
    End With
    For b = 7 To 10
    With .FormatConditions(1).Borders
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Next
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = RGB(155, 195, 230)
        .TintAndShade = 0
    End With
    .FormatConditions(1).StopIfTrue = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With .Offset(1, 0).Resize(4, 1)
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=COUNTA(" & .Offset(1, 0).Resize(4, 1).Address & ")<>0"
    .FormatConditions(.FormatConditions.Count).SetFirstPriority
    With .FormatConditions(1).Font
        .Bold = True
        .Italic = False
        .TintAndShade = 0
    End With
    For b = 7 To 10
    With .FormatConditions(1).Borders
        .LineStyle = xlContinuous
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Next
    With .FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = RGB(220, 235, 245)
        .TintAndShade = 0
    End With
    .FormatConditions(1).StopIfTrue = False
    
        End With


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


For i = 1 To 4

    With .Offset(i, 0)
    .Value = "=IFERROR(INDEX(" & SrcBC & ",AGGREGATE(15,6,(ROW(" & codtBC & ")-ROW(" & codtSC & ")+1)/(" & codtBC & "=" & Cells(StrtRw + i, StrtCl).Address & "),COLUMNS(" & CntCL & "))),"""")"
    End With
    
Next

End With

Next




End Sub
 

drsarao

Well-known Member
Joined
Sep 9, 2009
Messages
1,141
Another VBA solution:
Sorting of classes and students done.

VBA Code:
Sub StudentTranspose()
Dim dataread, datawrite(), cls()
Dim lr As Long, c As Long, lc As Long
Dim i As Long, j As Long, n As Long
Dim unq As Boolean
With Worksheets("Sheet1")
    lr = .Cells(.Rows.Count, "A").End(xlUp).Row
    .Range("A1:B" & lr).Sort key1:=.Range("A1"), Order1:=xlAscending, _
        key2:=.Range("B1"), Order2:=xlAscending, Header:=xlYes
    dataread = .Range("A1:B" & lr)
End With
ReDim cls(1 To 26, 1 To 2) 'A to Z
cls(1, 1) = dataread(2, 1) 'first class
cls(1, 2) = 1 'counter
c = 1
For i = 3 To lr
    unq = True
    For j = 1 To c
        If cls(j, 1) = dataread(i, 1) Then
            unq = False
            cls(j, 2) = cls(j, 2) + 1
            If lc < cls(j, 2) Then lc = cls(j, 2)
            Exit For
        End If
    Next j
    If unq Then
        c = c + 1
        cls(c, 1) = dataread(i, 1)
    End If
Next i
ReDim datawrite(1 To c + 2, 1 To lc + 2)
datawrite(1, 1) = dataread(1, 1)
For n = 2 To c + 1 'fill Class Names
    datawrite(n, 1) = cls(n - 1, 1)
    cls(n - 1, 2) = 1 'reset
Next n
For n = 1 To lc 'fill student name headers
    datawrite(1, n + 1) = "Student" & n
Next n
datawrite(2, 2) = dataread(2, 2)
For i = 3 To lr 'read counter
    For j = 1 To c
        If cls(j, 1) = dataread(i, 1) Then
            datawrite(j + 1, cls(j, 2) + 1) = dataread(i, 2)
            cls(j, 2) = cls(j, 2) + 1
        End If
    Next j
Next i
Worksheets("Sheet2").Range("A1").Resize(c + 1, lc) = datawrite
End Sub
 

BoyBoy

New Member
Joined
Sep 25, 2020
Messages
26
Office Version
  1. 365
Platform
  1. Windows
Greetings
what Abut Using Formula?

I think this will be help full for your Project


Thanks
VBA Code:
=IFERROR(INDEX($B$2:$B$16,AGGREGATE(15,6,(ROW($A$2:$A$16)-ROW($A$2)+1)/($A$2:$A$16=$D2),COLUMNS($A1:A1))),"")

Book1
ABCDEFGHIJKLMNO
1Class Name Student NameClass Name Student Name1 Student Name2Student Name3Student Name4Student Name5Student Name6Student Name7Student Name8Student Name9Student Name10Student Name11
2ClassANancy ClassANancy Lily Kate Wendy Jay Judy Nigel     
3ClassALily ClassBJohn Andy Kelly         
4ClassBJohn ClassCMandy Jennifer Bruce         
5ClassAKate ClassDRob Johnny          
6ClassAWendy
7ClassAJay
8ClassBAndy
9ClassBKelly
10ClassAJudy
11ClassCMandy
12ClassCJennifer
13ClassANigel
14ClassCBruce
15ClassDRob
16ClassDJohnny
Sheet2
Cell Formulas
RangeFormula
E2:O5E2=IFERROR(INDEX($B$2:$B$16,AGGREGATE(15,6,(ROW($A$2:$A$16)-ROW($A$2)+1)/($A$2:$A$16=$D2),COLUMNS($A1:A1))),"")
Thank you so much!
 

Watch MrExcel Video

Forum statistics

Threads
1,114,528
Messages
5,548,576
Members
410,852
Latest member
WernerS
Top