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
 
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
 
Upvote 0

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Did you copy/paste the code I supplied, or re-type?
Also did you make any changes to it?
 
Upvote 0
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
 
Upvote 0
Can you answer my questions in post#12
 
Upvote 0
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
 
Upvote 0
Glad you sorted it & thanks for the feedback.
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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!
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top