Merge records with duplicate ID and combine different data-CodePudding

Here is a sample of data from my worksheet. It has been sorted in Column B from smallest to largest to show the duplicate Item Codes (highlighted yellow):

Here is a breakdown of the following columns:

Column A - ID, every ID is unique
Column B - Item Code, duplicates appear
Columns C to E - A range of different data, but if two records have the same Item Code (B), the rest of the data (C to E) will remain the same, as seen above
Columns F to L - Week numbers (52 in a year hence back to 1 in column K) contains numeric values. Despite multiple records could have the same Item Code (B), columns could contain different numeric values (notice the red marks in the above screenshot)

I want to merge these records, based on finding duplicate Item Codes (B), resulting in storing the first ID value (A), merging columns C to E and combing columns F to L. The screenshot below shows my desired output.

As you can see, the records have been combined and merged. Those with a red mark indicate how these numeric values have been added together to show a new value when there are 2 or more records with the same Item Code but have multiple numeric values in the same column. If there is only one value, it merges with the rest to create one row per Item Code.

I have looked online for a long time and all I could find was using Consolidate and using VBA code to combine these records in a format that didn't lead to this desired output, including using formulas.

Thank you!

CodePudding user response：

Please, test the next code. It returns (now) in the next sheet against the processed one, but you can set the destination sheet as you want. As I said in my above comment, it uses arrays and a dictionary and should be very fast. Records can be in any order:

Sub ConsolidateItemCodes()
   Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
   Dim i As Long, j As Long, k As Long, dict As Object
   
   Set sh = ActiveSheet 'use here the sheet you need processing
   Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
   
   If sh.FilterMode Then sh.ShowAllData 'to show all data in case of filters...

   lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
   arrH = sh.Range("A1:L1").Value2           'the headers
   arr = sh.Range("A2:L" & lastR).Value2  'place the range in an array for faster iteration/processing
   ReDim arrVal(0 To 6) 'redim the array keeping the values
    
   'load the dictionary (ItemCodes as unique keys):
   Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
   For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 2)) Then
            For j = 0 To 6: arrVal(j) = arr(i, j   6): Next j
            dict.Add arr(i, 2), Array(Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5)), arrVal)
        Else
            arrIt = dict(arr(i, 2))  'a dictionary item can be adaptet directly, EXCEPT arrays...
            For j = 0 To 6
                arrIt(1)(j) = arrIt(1)(j)   arr(i, j   6)
            Next j
            dict(arr(i, 2)) = arrIt 'place back the updated jagged array
        End If
   Next i
 
   'process dictionary content
   ReDim arrfin(1 To dict.count   1, 1 To UBound(arr, 2))
   
   'place the header in the final array:
   For i = 1 To UBound(arrH, 2): arrfin(1, i) = arrH(1, i): Next i
   
   'extract data from dictionary:
   k = 1
   For j = 0 To dict.count - 1
        k = k   1
        arrIt = dict.Items()(j)
        arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = dict.keys()(j)
        arrfin(k, 3) = arrIt(0)(1): arrfin(k, 4) = arrIt(0)(2): arrfin(k, 5) = arrIt(0)(3)
        For i = 0 To 6: arrfin(k, i   6) = arrIt(1)(i): Next i
   Next j
   
   'drop the processed array content at once:
   With destSh.Range("A1").Resize(k, UBound(arrfin, 2))
        .Value2 = arrfin
        .rows(1).Font.Bold = True
        .EntireColumn.AutoFit
    End With
    
    MsgBox "Ready..."
End Sub

I tried commenting all code lines, to be easy understood. If something still not clear enough, do not hesitate to ask for clarifications.

Please, send some feedback after testing it.