to array or not? (summing up same category in range)

[airforceone]

It's been 2 weeks now since I started a mini project but my clogged brain won't cooperate with me
I hate to burden but can anyone help me, given the sample data I would like to merge all Med Category and its corresponding grams and value (number of Med per Unique Numbers Varies)
I hope I explained it clearly

Online File.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	UNIQUE NUMBER	UNDER	DATE	CLASS	MED	Grams	Value	MED	Grams	Value	MED	Grams	Value	MED	Grams	Value
2	A0001	PHA 1	2016.01.20	OTC	VIT - A	1	5
3	A0002	PHA 2	2016.03.18	NON-TAKERS	VIT - B	1	5	VIT - E	3	15
4	A0003	PHA 3	2016.04.19	OTC	VIT - C	2	10	VIT - C	4	20	VIT - C	1	5
5	A0004	PHA 4	2016.04.22	SIGNED	VIT - D	3	15	VIT - D	5	25	VIT - D	1	5	VIT - C	1	5
6	A0005	PHA 5	2016.05.25	NON-TAKERS	VIT - D	4	20	VIT - E	6	30	VIT - E	2	10
7	A0006	PHA 6	2016.06.23	OTC	VIT - E	5	25
8
9
10	EXPECTED OUTPUT
11	UNIQUE NUMBER	UNDER	DATE	CLASS	MED	Grams	Value	MED	Grams	Value	MED	Grams	Value	MED	Grams	Value
12	A0001	PHA 1	2016.01.20	OTC	VIT - A	1	5
13	A0002	PHA 2	2016.03.18	NON-TAKERS	VIT - B	1	5	VIT - E	3	15
14	A0003	PHA 3	2016.04.19	OTC	VIT - C	7	35
15	A0004	PHA 4	2016.04.22	SIGNED	VIT - D	9	45	VIT - C	1	5
16	A0005	PHA 5	2016.05.25	NON-TAKERS	VIT - D	4	20	VIT - E	8	40
17	A0006	PHA 6	2016.06.23	OTC	VIT - E	5	25
VITs

 

[airforceone]

Cheer!
BTW, could you share your latest data with null cells, and final code?

ok will do, re-create my actual data to dummy record first

 

[airforceone]

Cheer!
BTW, could you share your latest data with null cells, and final code?

Sample Table

kindly note comment inside body of code
Try running code for Sheets with EMPTY/NULL cell Value and without

Sub MergeParseII()

'----------------------------
'
'   CODE FOR MERGING VITs per SET
'
    Dim lr&, lc&, i&, j&, k&, rng, arr()
    Dim dic As Object, key
    
    lr = Cells(rows.Count, "D").End(xlUp).Row
    
'   NOTE FOR THE WOULD BE TESTER / CONTRIBUTOR
'
'   original code from the contributor
'   using below code without header / lable on row 1 generates error
'
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    
'   new code to address header problem
'   using below code does not generates error even without lables on row 1
'
    lc = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

    rng = range("E2", Cells(lr, lc)).Value
    For i = 1 To UBound(rng)
        Set dic = CreateObject("Scripting.dictionary")
        ReDim arr(1 To 1, 1 To lc - 4)
        k = 0
        For j = 1 To UBound(rng, 2) Step 3
        If rng(i, j) <> "" Then
            If Not dic.exists(rng(i, j)) Then
                dic.Add rng(i, j), rng(i, j + 1) & "|" & rng(i, j + 2)
            Else
                dic(rng(i, j)) = Split(dic(rng(i, j)), "|")(0) + rng(i, j + 1) & "|" & Split(dic(rng(i, j)), "|")(1) + rng(i, j + 2)
            End If
        End If
        Next
        For Each key In dic.keys
            k = k + 1: arr(1, k) = key
            k = k + 1: arr(1, k) = Split(dic(key), "|")(0)
            k = k + 1: arr(1, k) = Split(dic(key), "|")(1)
        Next
'
'   appended as advice by the contributor
'        Cells(i + 1, 23).Resize(1, dic.Count).Value = dic.items

        range(Cells(i + 1, 5), Cells(i + 1, 10000)).ClearContents
        Cells(i + 1, 5).Resize(1, k).Value = arr
        dic.RemoveAll
    Next
    
End Sub     '   MergeParseII