VBA Codes to do unique part codes from one column and also sum of these

So...Must Unique B|C|D of each sheet be populated in Col's J to O of each sheet...
Is the data in first sheet J-O as a example...

Sub J3v16()
Dim Data, Dict As Object, ws As Worksheet, str As String, i As Long
Application.ScreenUpdating = False
Set Dict = CreateObject("scripting.dictionary")
For Each ws In Sheets
    With ws
        Data = .Range("B7:G" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        For i = 1 To UBound(Data)
            If Not IsEmpty(Data(i, 1)) Then
                str = Join(Array(Data(i, 1), Data(i, 2), Data(i, 3)), ";")
                If Not Dict.exists(str) Then
                    Dict.Add str, Data(i, 4) & ";" & Data(i, 6) / Data(i, 4) & ";" & Data(i, 6)
                Else
                     Dict.Item(str) = Split(Dict.Item(str), ";")(0) + Data(i, 4) & ";" & Data(i, 6) / Split(Dict.Item(str), ";")(0) & ";" & Split(Dict.Item(str), ";")(2) + Data(i, 6)
                End If
            End If
        Next i
        Range("J6").Resize(, 6) = Range("B6").Resize(, 6).Value
        With .Range("J7").Resize(Dict.Count)
            .Value = Application.Transpose(Dict.keys)
            .TextToColumns .Cells(1), xlDelimited, Semicolon:=True
            With .Offset(, 3).Resize(Dict.Count): .Value = Application.Transpose(Dict.items)
                .TextToColumns .Cells(1), xlDelimited, Semicolon:=True
            End With
        End With
        .Columns.AutoFit
    End With
Next ws
Application.ScreenUpdating = True
End Sub

.........................
Thanks.png