VBA to transpose blocks (arrays) of data

[Antonf]

I have to transform literally hundreds of blocks of data exported from financial software into a different format for my manager.
The source data is on the left in the image and the required output is on the right.
Doing it manually is not that difficult but i will drive me to drink!
Any help will be highly appreciated!

Transpose.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Code	Description	Mar 2023	Apr 2023	May 2023	Jun 2023							4001	9045	9150
2	NR0001	Name1									NR0001	Name1
3	4001		7.91	7.91	7.91	7.91						Mar 2023	7.91	177.12	178.73
4	9045		177.12	177.12	177.12	177.12						Apr 2023	7.91	177.12	182.54
5	9150		178.73	182.54	229.54	191.93						May 2023	7.91	177.12	229.54
6	NR0004	Name2										Jun 2023	7.91	177.12	191.93
7	4001		7.91	7.91	7.91	7.91					NR0004	Name2
8	9045		177.12	177.12	177.12	177.12						Mar 2023	7.91	177.12	551.67
9	9150		551.67	514.18	664.42	636.36						Apr 2023	7.91	177.12	514.18
10												May 2023	7.91	177.12	664.42
11												Jun 2023	7.91	177.12	636.36
Sheet1

 

[Kerryx]

Book3
	A	B	C	D	E	F
1	NR	Description	Attribute	8001	9045	9150
2	AM002	Name1	Jul-23	2018.47	177.12	191.93
3	AM004	Mr Robin Shawn Van Biljon	Jul-23	13760.3	177.12	567.7
Table1

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Code", type any}, {"Description", type text}, {"Jul-23", type number}}),
    #"Added Custom" = Table.AddColumn(#"Changed Type", "NR", each if [Code]= Text.Select([Code], {"0".."9"} ) then null else [Code]),
    #"Replaced Errors" = Table.ReplaceErrorValues(#"Added Custom", {{"NR", null}}),
    #"Filled Down" = Table.FillDown(#"Replaced Errors",{"NR"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Filled Down",{"Code", "NR", "Description", "Jul-23"}),
    #"Filled Down1" = Table.FillDown(#"Reordered Columns",{"Description"}),
    #"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Filled Down1", {"Code", "NR", "Description"}, "Attribute", "Value"),
    #"Pivoted Column" = Table.Pivot(Table.TransformColumnTypes(#"Unpivoted Columns", {{"Code", type text}}, "en-IE"), List.Distinct(Table.TransformColumnTypes(#"Unpivoted Columns", {{"Code", type text}}, "en-IE")[Code]), "Code", "Value", List.Sum)
in
    #"Pivoted Column"

 

[Kerryx]

When you copied you seem to have missed this piece, highlighted in red below

 

[RudRud]

Another option through VBA, For your reference:

工作簿1.xlsb
	A	B	C	D	E	F	G
1	Code	Description	Mar-23	Apr-23	May-23	Jun-23	Jul-23
2	NR0001	Name1
3	4001		7.91	7.91	7.91	7.91	2
4	9045		177.12	177.12	177.12	177.12	3
5	9150		178.73	182.54	229.54	191.93	3
6	NR0004	Name2
7	4001		7.91	7.91	7.91	7.91	5
8	9045		177.12	177.12	177.12		6
9	9150		551.67	514.18		636.36	7
Sheet1

Need to put code in sheet2 column G & H ( Code and column number)

工作簿1.xlsb
	A	B	C	D	E	F	G	H
1			4001	9045	9150		4001	3
2	NR0001	Name1					9045	4
3		3/1/23	7.91	177.12	178.73		9150	5
4		4/1/23	7.91	177.12	182.54
5		5/1/23	7.91	177.12	229.54
6		6/1/23	7.91	177.12	191.93
7		7/1/23	2	3	3
8	NR0004	Name2
9		3/1/23	7.91	177.12	551.67
10		4/1/23	7.91	177.12	514.18
11		5/1/23	7.91	177.12
12		6/1/23	7.91		636.36
13		7/1/23	5	6	7
Sheet2

Option Explicit
Sub test()
Dim a As Variant, T As Variant
Dim ws2 As Worksheet
Set ws2 = Sheets("sheet2") ' output
Dim ws As Worksheet
Set ws = Sheets("sheet1") ' data
ReDim b(1 To 100000, 1 To 6)
Dim dict As Object
'Dim dict As New Dictionary
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim month%, i%, lastcol%, lrow%, k%, j%

a = ws2.Range("g1:h" & ws2.Cells(Rows.Count, "g").End(xlUp).Row).Value 'Add Code to Array

For i = 1 To UBound(a, 1)
    dict.Add a(i, 1), a(i, 2) 'Add code to dictionary
Next i

With ws
    lastcol = .UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
    lrow = .Cells(Rows.Count, "A").End(xlUp).Row
    a = .Range(.Cells(1, 1), .Cells(lrow, lastcol)).Value  'Redefine array from a1 to G last row
    month = lastcol - 2
End With

For i = 2 To UBound(a, 1) 'Loop through data
    If Len(a(i, 2)) >= 5 Then 'desc
         k = IIf(k > 0, k + month, k + 1)
         b(k, 1) = a(i, 1) 'Name
         b(k, 2) = a(i, 2) 'Desc
    End If
   
    If dict.Exists(a(i, 1)) Then
            For j = 1 To month 'loop through month
                b(k + j, 2) = a(1, j + 2)
                b(k + j, dict(a(i, 1))) = a(i, j + 2) '
            Next j
    End If

Next i

T = dict.Keys
With ws2
    .Range("c1").Resize(, UBound(T, 1) + 1).Value = T
    .[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b
End With

End Sub

 

[Antonf]

OMW, being blonde does have serious implications!!!!

Thank you so much once again!!!