Macro for transposing Column to muliple rows

A

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

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Sort by date Sort by votes
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
ann19san said:
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]
Click to expand...

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
Fluff said:
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
Click to expand...


Very Concise Code Nice Fluff ..
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Conditional formatting - Automatic banding of months
Replies
4
Views
129
etaf
etaf
V
  • Solved
Formula to calculate automatically progressive average
Replies
5
Views
496
etaf
etaf
J
  • Question Question
adding cells based on criteria across several columns
Replies
5
Views
848
Cubist
Cubist
ExcelNewbie2020
  • Solved
Single Spill Array Formula with Transpose function
Replies
2
Views
95
djclements
djclements
S
  • Solved
lookup return from range of dates
Replies
4
Views
496
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

Share this page

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