Rotating Data from Horizontal to Vertical using VBA Code

[Saacko]

Hi everyone, please let me know if someone has a VBA code that can format data to how I need it. Here is what my new data set looks like, my current data is in rows 1-5 and in rows. It goes for hundreds of columns wide. 10-21 is an example of how I would like those columns to be moved:

Buy On Paper - RevD - Macro-Enabled.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X
1	Project Set-Up								Material Contract 5								Material Contract 4
2	1.Project Set-Up - NTP to IFR, Hours	1. PSU - Project Set-Up	0	FS	Procurement Execution	PCRMT-MGR	100	Linear	1.Material Contract 5 - NTP to IFR, Hours	1. MC5 - Material Contract 5	200	FS	Procurement Execution	PCRMT-MGR	49	Linear	1.Material Contract 4 - NTP to IFR, Hours	1. MC4 - Material Contract 4	280	FS	Procurement Execution	PCRMT-MGR	36	Linear
3	2.Project Set-Up - IFR to Quote (Proposal Received), Hours	2. PSU - 1.Project Set-Up - NTP to IFR, Hours	100	FS		PCRMT-SPT 1	60	Linear	2.Material Contract 5 - IFR to Quote (Proposal Received), Hours	2. MC5 - 1.Material Contract 5 - NTP to IFR, Hours	340	FS		PCRMT-SPT 1	22	Linear	2.Material Contract 4 - IFR to Quote (Proposal Received), Hours	2. MC4 - 1.Material Contract 4 - NTP to IFR, Hours	320	FS		PCRMT-SPT 1	18	Linear
4	3.Project Set-Up - Quote (Proposal Received) to Award, Hours	3. PSU - 2.Project Set-Up - IFR to Quote (Proposal Received), Hours	100	FS		PCRMT-SPT 2	0	Linear	3.Material Contract 5 - Quote (Proposal Received) to Award, Hours	3. MC5 - 2.Material Contract 5 - IFR to Quote (Proposal Received), Ho	280	FS		PCRMT-SPT 2	22	Linear	3.Material Contract 4 - Quote (Proposal Received) to Award, Hours	3. MC4 - 2.Material Contract 4 - IFR to Quote (Proposal Received), Ho	260	FS		PCRMT-SPT 2	18	Linear
5	4.Project Set-Up - Award to Delivery or Completion, Hours	4. PSU - 3.Project Set-Up - Quote (Proposal Received) to Award, Hours	0	FS					4.Material Contract 5 - Award to Delivery or Completion, Hours	4. MC5 - 3.Material Contract 5 - Quote (Proposal Received) to Award,	2920	FS					4.Material Contract 4 - Award to Delivery or Completion, Hours	4. MC4 - 3.Material Contract 4 - Quote (Proposal Received) to Award,	1920	FS
6
7
8
9	Package Name	Abbreviation	Duration	Logic	LOE Title	Resource	Man Hours	Curve
10	1.Project Set-Up - NTP to IFR, Hours	1. PSU - Project Set-Up	0	FS	Procurement Execution	PCRMT-MGR	100	Linear
11	2.Project Set-Up - IFR to Quote (Proposal Received), Hours	2. PSU - 1.Project Set-Up - NTP to IFR, Hours	100	FS		PCRMT-SPT 1	60	Linear
12	3.Project Set-Up - Quote (Proposal Received) to Award, Hours	3. PSU - 2.Project Set-Up - IFR to Quote (Proposal Received), Hours	100	FS		PCRMT-SPT 2	0	Linear
13	4.Project Set-Up - Award to Delivery or Completion, Hours	4. PSU - 3.Project Set-Up - Quote (Proposal Received) to Award, Hours	0	FS
14	1.Material Contract 5 - NTP to IFR, Hours	1. MC5 - Material Contract 5	200	FS	Procurement Execution	PCRMT-MGR	49	Linear
15	2.Material Contract 5 - IFR to Quote (Proposal Received), Hours	2. MC5 - 1.Material Contract 5 - NTP to IFR, Hours	340	FS		PCRMT-SPT 1	22	Linear
16	3.Material Contract 5 - Quote (Proposal Received) to Award, Hours	3. MC5 - 2.Material Contract 5 - IFR to Quote (Proposal Received), Ho	280	FS		PCRMT-SPT 2	22	Linear
17	4.Material Contract 5 - Award to Delivery or Completion, Hours	4. MC5 - 3.Material Contract 5 - Quote (Proposal Received) to Award,	2920	FS
18	1.Material Contract 4 - NTP to IFR, Hours	1. MC4 - Material Contract 4	280	FS	Procurement Execution	PCRMT-MGR	36	Linear
19	2.Material Contract 4 - IFR to Quote (Proposal Received), Hours	2. MC4 - 1.Material Contract 4 - NTP to IFR, Hours	320	FS		PCRMT-SPT 1	18	Linear
20	3.Material Contract 4 - Quote (Proposal Received) to Award, Hours	3. MC4 - 2.Material Contract 4 - IFR to Quote (Proposal Received), Ho	260	FS		PCRMT-SPT 2	18	Linear
21	4.Material Contract 4 - Award to Delivery or Completion, Hours	4. MC4 - 3.Material Contract 4 - Quote (Proposal Received) to Award,	1920	FS
22
Final Data Set

My tab of the sheet is named "Final Data Set"

@kevin9999

Please let me know if you can help,

Thanks

Scout

 

[kevin9999]

Please try the following on a copy of your workbook.

Option Explicit
Sub Saacko_V2()
Dim ws As Worksheet, LCol As Long
Set ws = Worksheets("Final Data Set")
    LCol = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    Dim ArrIn(), arrOut(), arr()
    Dim nRng As Long, i As Long, j As Long
    nRng = LCol / 8
    ReDim ArrIn(1 To nRng)
    
    'Load the input array
    With ws
        j = 1
        For i = 1 To nRng
            ArrIn(i) = ws.Cells(2, j).Resize(4, 8)
            j = j + 8
        Next i
    End With
    
    'Load the output array
    Dim rw As Long, col As Long, r As Long
    ReDim arrOut(1 To LCol, 1 To 8)
    r = 1
    For i = 1 To nRng
        arr = ArrIn(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                arrOut(r, col) = arr(rw, col)
                Next col
            r = r + 1
        Next rw
    Next i
    
    'Write the array to the sheet
    ws.Range("A10").Resize(LCol, 8).Value = arrOut
End Sub

 

[Saacko]

Thank you so much this worked literally perfect. I am so thankful once again.

Have a great one Kevin

 

[kevin9999]

You're more than welcome & thanks for the feedback