Macro for transposing Column to muliple rows

[ann19san]

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:

Date	Amount
Oct 14, 2017	1
Oct 21, 2017	2
Oct 28, 2017	3
Nov 4, 2017	4
Nov 11, 2017	5
Nov 18, 2017	6
Nov 25, 2017	7
Dec 2, 2017	8
Dec 9, 2017	9
Dec 16, 2017	10
Dec 23, 2017	11
Dec 30, 2017	12
Jan 6, 2018	13
Jan 13, 2018	14
Oct 14, 2017	15
Oct 21, 2017	16
Oct 28, 2017	17
Nov 4, 2017	18
Nov 11, 2017	19
Nov 18, 2017	20
Nov 25, 2017	21
Dec 2, 2017	22
Dec 9, 2017	23
Dec 16, 2017	24
Dec 23, 2017	25
Dec 30, 2017	26
Jan 6, 2018	27
Jan 13, 2018	28
Oct 14, 2017	29
Oct 21, 2017	30
Oct 28, 2017	31
Nov 4, 2017	32
Nov 11, 2017	33
Nov 18, 2017	34
Nov 25, 2017	35
Dec 2, 2017	36
Dec 9, 2017	37
Dec 16, 2017	38
Dec 23, 2017	39
Dec 30, 2017	40
Jan 6, 2018	41
Jan 13, 2018	42

<colgroup><col><col></colgroup><tbody>
</tbody>

Result in Sheet 2:

Oct 14, 2017	Oct 21, 2017	Oct 28, 2017	Nov 4, 2017	Nov 11, 2017	Nov 18, 2017	Nov 25, 2017	Dec 2, 2017	Dec 9, 2017	Dec 16, 2017	Dec 23, 2017	Dec 30, 2017	Jan 6, 2018	Jan 13, 2018
1	2	3	4	5	6	7	8	9	10	11	12	13	14
15	16	17	18	19	20	21	22	23	24	25	26	27	28
29	30	31	32	33	34	35	36	37	38	39	40	41	42

<colgroup><col span="3"><col><col span="3"><col span="2"><col span="3"><col><col></colgroup><tbody>
</tbody>

 

[James006]

Hello,

In your Sheet 2 cell A1, you can have :

=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 :

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

To be copied for the whole Sheet 2 ...

Hope this will help

 

[ann19san]

Thanks James!!! This works well.

 

[Kmis456]

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:

Date	Amount
Oct 14, 2017	1
Oct 21, 2017	2
Oct 28, 2017	3
Nov 4, 2017	4
Nov 11, 2017	5
Nov 18, 2017	6
Nov 25, 2017	7
Dec 2, 2017	8
Dec 9, 2017	9
Dec 16, 2017	10
Dec 23, 2017	11
Dec 30, 2017	12
Jan 6, 2018	13
Jan 13, 2018	14
Oct 14, 2017	15
Oct 21, 2017	16
Oct 28, 2017	17
Nov 4, 2017	18
Nov 11, 2017	19
Nov 18, 2017	20
Nov 25, 2017	21
Dec 2, 2017	22
Dec 9, 2017	23
Dec 16, 2017	24
Dec 23, 2017	25
Dec 30, 2017	26
Jan 6, 2018	27
Jan 13, 2018	28
Oct 14, 2017	29
Oct 21, 2017	30
Oct 28, 2017	31
Nov 4, 2017	32
Nov 11, 2017	33
Nov 18, 2017	34
Nov 25, 2017	35
Dec 2, 2017	36
Dec 9, 2017	37
Dec 16, 2017	38
Dec 23, 2017	39
Dec 30, 2017	40
Jan 6, 2018	41
Jan 13, 2018	42

<tbody>
</tbody>

Result in Sheet 2:

Oct 14, 2017	Oct 21, 2017	Oct 28, 2017	Nov 4, 2017	Nov 11, 2017	Nov 18, 2017	Nov 25, 2017	Dec 2, 2017	Dec 9, 2017	Dec 16, 2017	Dec 23, 2017	Dec 30, 2017	Jan 6, 2018	Jan 13, 2018
1	2	3	4	5	6	7	8	9	10	11	12	13	14
15	16	17	18	19	20	21	22	23	24	25	26	27	28
29	30	31	32	33	34	35	36	37	38	39	40	41	42

<tbody>
</tbody>

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

 

[Fluff]

If you're still interested in a macro, how about

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

 

[Kmis456]

If you're still interested in a macro, how about

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