Adjusting a transpose macro - and failing

[Gemma S]

Hi

I have some transposition to do from columns to rows and I think I have the ideal bit of code posted by @maabadi . My circumstances are almost exactly the same except I have two more columns. However I cant figure our how to make the simple adjustment and I am getting worse. The data I need to transpose is:-

The output should be

I am using the code kindly posted by @maabadi on Transpose date from rows to columns for multiple rows using macro

How should I amend it for the extra fields?

Sub TransformData()
Dim i As Long, Lr As Long, j As Long, Cell As Range, Lc As Long, L As Long, K1 As Long
Dim Lr2 As Long
Lr = Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(2, Columns.Count).End(xlToLeft).Column
Range("B" & Lr + 2).Value = "Project Type"
Range("C" & Lr + 2).Value = "Project #"
Range("D" & Lr + 2).Value = "Project Name"
Range("E" & Lr + 2).Value = "Date"
Range("F" & Lr + 2).Value = "Amount"
Lr2 = Lr + 3
For i = 3 To Lr
L = 0
K1 = Application.WorksheetFunction.Count(Range(Cells(i, 5), Cells(i, Lc))) - 1
Range("B" & Lr2 & ":B" & Lr2 + K1).Value = Range("C" & i).Value
Range("C" & Lr2 & ":C" & Lr2 + K1).Value = Range("B" & i).Value
Range("D" & Lr2 & ":D" & Lr2 + K1).Value = Range("A" & i).Value
For j = 5 To Lc
If Cells(i, j).Value = "" Then
Else
Range("E" & Lr2 + L).Value = Cells(2, j).Value
Range("F" & Lr2 + L).Value = Cells(i, j).Value
L = L + 1
End If
Next j
Lr2 = Range("B" & Rows.Count).End(xlUp).Row + 1
Next i

End Sub

 

[Fluff]

You haven't said where the output should go, so I've put it into a sheet called Sheet2

Sub GemmaS()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
  
   Ary = Range("A2:Q" & Range("A" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 7)
   For r = 1 To UBound(Ary)
      For c = 6 To UBound(Ary, 2)
         nr = nr + 1
         For nc = 1 To 5
            Nary(nr, nc) = Ary(r, nc)
         Next nc
         Nary(nr, 6) = Ary(1, c)
         Nary(nr, 7) = Ary(r, c)
      Next c
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 7).Value = Nary
End Sub

 

[veyselemre]

      For c = 6 To UBound(Ary)

in its place,

        For c = 6 To UBound(Ary, 2)

must be.

 

[Fluff]

Well spotted & thanks for that , I have change the original code.

 

[alansidman]

Since you are using 365, you can unpivot the data using Get and Transform found on the Data Tab.

Data-->Get and Transform Data-->From Table or Range
In the PQ editor
Transform-->Unpivot (Highlight columns A:E), Unpivot Other columns
Home-->Load and Close To Select the location you wish to place the data in Native Excel.

 

[Gemma S]

Thank you that is great.

The only thing still ont quite right is that it is using row 2 for the periods rather than row 1 - should I lay out my data differently

 

[Fluff]

Oops, it should be

Sub GemmaS()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   Ary = Range("A1:Q" & Range("A" & Rows.Count).End(xlUp).Row).Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 7)
   For r = 2 To UBound(Ary)
      For c = 6 To UBound(Ary, 2)
         nr = nr + 1
         For nc = 1 To 5
            Nary(nr, nc) = Ary(r, nc)
         Next nc
         Nary(nr, 6) = Ary(1, c)
         Nary(nr, 7) = Ary(r, c)
      Next c
   Next r
   Sheets("Sheet2").Range("A2").Resize(nr, 7).Value = Nary
End Sub

 

[alansidman]

Who are you referring to in post #6. If me, then suggest you use XL2BB to upload your sample file as I can not manipulate data in a picture to provide you with the Mcode.

 

[Fluff]

Me. That's why I corrected my code.