Macro for transposing Column to muliple rows

ann19san

New Member
Joined
Dec 12, 2017
Messages
4
Can someone help me help me how to create a macro that would transpose the following amount in column to rows that match the dates, here is an example:
Raw data from sheet 1:
[TABLE="width: 166"]
<colgroup><col><col></colgroup><tbody>[TR]
[TD]Date[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]12[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]13[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]15[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]16[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]17[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]19[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]20[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]22[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]24[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]25[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]26[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]27[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]28[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]29[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]31[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]32[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]33[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]34[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]35[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]36[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]37[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]38[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]39[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]40[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]41[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]42[/TD]
[/TR]
</tbody>[/TABLE]

Result in Sheet 2:
[TABLE="width: 1061"]
<colgroup><col span="3"><col><col span="3"><col span="2"><col span="3"><col><col></colgroup><tbody>[TR]
[TD]Oct 14, 2017[/TD]
[TD]Oct 21, 2017[/TD]
[TD]Oct 28, 2017[/TD]
[TD]Nov 4, 2017[/TD]
[TD]Nov 11, 2017[/TD]
[TD]Nov 18, 2017[/TD]
[TD]Nov 25, 2017[/TD]
[TD]Dec 2, 2017[/TD]
[TD]Dec 9, 2017[/TD]
[TD]Dec 16, 2017[/TD]
[TD]Dec 23, 2017[/TD]
[TD]Dec 30, 2017[/TD]
[TD]Jan 6, 2018[/TD]
[TD]Jan 13, 2018[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD]13[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]16[/TD]
[TD]17[/TD]
[TD]18[/TD]
[TD]19[/TD]
[TD]20[/TD]
[TD]21[/TD]
[TD]22[/TD]
[TD]23[/TD]
[TD]24[/TD]
[TD]25[/TD]
[TD]26[/TD]
[TD]27[/TD]
[TD]28[/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD]30[/TD]
[TD]31[/TD]
[TD]32[/TD]
[TD]33[/TD]
[TD]34[/TD]
[TD]35[/TD]
[TD]36[/TD]
[TD]37[/TD]
[TD]38[/TD]
[TD]39[/TD]
[TD]40[/TD]
[TD]41[/TD]
[TD]42[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Hello,

In your Sheet 2 cell A1, you can have :

Code:
=OFFSET(Sheet1!$A$2,((ROW()-1)*14)+COLUMN()-1,0)

To be copied for the whole of Row 1

AND in your Sheet 2 cell A2, you can have :

Code:
=OFFSET(Sheet1!$A$2,((ROW()-2)*14)+COLUMN()-1,1)

To be copied for the whole Sheet 2 ...

Hope this will help
 
Upvote 0
Can someone help me help me how to create a macro that would transpose the following amount in column to rows that match the dates, here is an example:
Raw data from sheet 1:
[TABLE="width: 166"]
<tbody>[TR]
[TD]Date[/TD]
[TD]Amount[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]12[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]13[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]15[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]16[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]17[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]18[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]19[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]20[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]21[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]22[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]24[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]25[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]26[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]27[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]28[/TD]
[/TR]
[TR]
[TD]Oct 14, 2017[/TD]
[TD]29[/TD]
[/TR]
[TR]
[TD]Oct 21, 2017[/TD]
[TD]30[/TD]
[/TR]
[TR]
[TD]Oct 28, 2017[/TD]
[TD]31[/TD]
[/TR]
[TR]
[TD]Nov 4, 2017[/TD]
[TD]32[/TD]
[/TR]
[TR]
[TD]Nov 11, 2017[/TD]
[TD]33[/TD]
[/TR]
[TR]
[TD]Nov 18, 2017[/TD]
[TD]34[/TD]
[/TR]
[TR]
[TD]Nov 25, 2017[/TD]
[TD]35[/TD]
[/TR]
[TR]
[TD]Dec 2, 2017[/TD]
[TD]36[/TD]
[/TR]
[TR]
[TD]Dec 9, 2017[/TD]
[TD]37[/TD]
[/TR]
[TR]
[TD]Dec 16, 2017[/TD]
[TD]38[/TD]
[/TR]
[TR]
[TD]Dec 23, 2017[/TD]
[TD]39[/TD]
[/TR]
[TR]
[TD]Dec 30, 2017[/TD]
[TD]40[/TD]
[/TR]
[TR]
[TD]Jan 6, 2018[/TD]
[TD]41[/TD]
[/TR]
[TR]
[TD]Jan 13, 2018[/TD]
[TD]42[/TD]
[/TR]
</tbody>[/TABLE]

Result in Sheet 2:
[TABLE="width: 1061"]
<tbody>[TR]
[TD]Oct 14, 2017[/TD]
[TD]Oct 21, 2017[/TD]
[TD]Oct 28, 2017[/TD]
[TD]Nov 4, 2017[/TD]
[TD]Nov 11, 2017[/TD]
[TD]Nov 18, 2017[/TD]
[TD]Nov 25, 2017[/TD]
[TD]Dec 2, 2017[/TD]
[TD]Dec 9, 2017[/TD]
[TD]Dec 16, 2017[/TD]
[TD]Dec 23, 2017[/TD]
[TD]Dec 30, 2017[/TD]
[TD]Jan 6, 2018[/TD]
[TD]Jan 13, 2018[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]2[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]5[/TD]
[TD]6[/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD]13[/TD]
[TD]14[/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD]16[/TD]
[TD]17[/TD]
[TD]18[/TD]
[TD]19[/TD]
[TD]20[/TD]
[TD]21[/TD]
[TD]22[/TD]
[TD]23[/TD]
[TD]24[/TD]
[TD]25[/TD]
[TD]26[/TD]
[TD]27[/TD]
[TD]28[/TD]
[/TR]
[TR]
[TD]29[/TD]
[TD]30[/TD]
[TD]31[/TD]
[TD]32[/TD]
[TD]33[/TD]
[TD]34[/TD]
[TD]35[/TD]
[TD]36[/TD]
[TD]37[/TD]
[TD]38[/TD]
[TD]39[/TD]
[TD]40[/TD]
[TD]41[/TD]
[TD]42[/TD]
[/TR]
</tbody>[/TABLE]

Hi,
Open new workbook and add sheet2 and use below code.


Sub TestUnique()
Dim Sh As Worksheet
Dim Dsh As Worksheet
Dim Cel As Range, Celadr As String
Dim i As Long
Dim Kt As Long


With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set Sh = ThisWorkbook.Worksheets("Sheet1")
Set Dsh = ThisWorkbook.Worksheets("Sheet2")
Dsh.Cells.ClearContents
Sh.Range("A2:A" & Sh.Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=Sh.Range("h1")
Sh.Range("h1:h" & Sh.Cells(Rows.Count, 1).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
Sh.Range("h1:h" & Sh.Cells(Rows.Count, 1).End(xlUp).Row).Copy
Dsh.Range("a1").PasteSpecial (xlPasteValues), Transpose:=True
Application.CutCopyMode = False
Sh.Range("h1").EntireColumn.ClearContents
For i = 1 To Dsh.Cells(1, Columns.Count).End(xlToLeft).Column
Set Cel = Sh.Cells.Find(Dsh.Cells(1, i))
Celadr = Cel.Address
If Not Cel Is Nothing Then
Do
Kt = Dsh.Cells(Rows.Count, i).End(xlUp).Row + 1
Dsh.Cells(Kt, i) = Cel.Offset(0, 1)
Set Cel = Sh.Cells.FindNext(Cel)
Loop While Not Cel Is Nothing And Cel.Address <> Celadr
End If


Next i






End Sub
 
Upvote 0
If you're still interested in a macro, how about
Code:
Sub CopyTransposeMultiRows()

   Dim Cl As Range
   Dim itm As Variant
   Dim Col As Long
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "," & Cl.Offset(, 1).Value
         End If
      Next Cl
      Col = 1
      Sheets("Sheet2").Range("A1").Resize(, .Count).Value = .keys
      For Each itm In .items
         Sheets("Sheet2").Cells(2, Col).Resize(UBound(Split(itm, ",")) + 1) = Application.Transpose(Split(itm, ","))
         Col = Col + 1
      Next itm
   End With
End Sub
 
Upvote 0
If you're still interested in a macro, how about
Code:
Sub CopyTransposeMultiRows()

   Dim Cl As Range
   Dim itm As Variant
   Dim Col As Long
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & "," & Cl.Offset(, 1).Value
         End If
      Next Cl
      Col = 1
      Sheets("Sheet2").Range("A1").Resize(, .Count).Value = .keys
      For Each itm In .items
         Sheets("Sheet2").Cells(2, Col).Resize(UBound(Split(itm, ",")) + 1) = Application.Transpose(Split(itm, ","))
         Col = Col + 1
      Next itm
   End With
End Sub


Very Concise Code Nice Fluff ..
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,180
Members
453,021
Latest member
Justyna P

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