Gemma S
New Member
- Joined
- Sep 9, 2020
- Messages
- 3
- Office Version
- 365
- Platform
- Windows
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
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