Try this code, please. It should be very fast, using arrays and working only in memory and does not need to color anything. The processing result, meaning only the unique values with the necessary sum per each column will be dropped on a new sheet added after the processed one:
Sub CombineDuplicates()
`It needs a reference to 'Microsoft Scripting Runtime'
Dim LROW As Long, arrA, arr, arrR(4), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
arrA = sh.Range("A4:A" & LROW).value
arr = sh.Range("J4:N" & LROW).value
For i = 1 To UBound(arrA)
If Not dict.Exists(arrA(i, 1)) Then
For j = 0 To 4
arrR(j) = arr(i, j + 1)
Next j
dict.Add arrA(i, 1), arrR
Else
For j = 0 To 4
arrR(j) = dict(arrA(i, 1))(j) + arr(i, j + 1)
Next j
dict(arrA(i, 1)) = arrR
End If
Next i
ReDim arrFin(1 To dict.Count, 1 To 5)
ReDim arrF(1 To dict.Count, 1 To 1)
For i = 0 To dict.Count - 1
arrF(i + 1, 1) = dict.Keys(i)
For j = 0 To 4
arrFin(i + 1, j + 1) = dict.items(i)(j)
Next
Next i
Set resSh = Worksheets.Add(After:=sh) 'add a new sheet aftere the active one and drop the array at once
resSh.Range("A2").Resize(UBound(arrF), 1).value = arrF
resSh.Range("J2").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
This approach will allow running the code as many times you need, after eventual updates or just in case. Otherwise, it will return double dates each next time...
If you have a problem with adding the necessary reference, please run the next code before the one able to process your data:
Sub addScrRunTimeRef()
'Add a reference to 'Microsoft Scripting Runtime':
'In case of error ('Programmatic access to Visual Basic Project not trusted'):
'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
' check "Trust access to the VBA project object model"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub
Edited:
If you insist to keep all the range, and making black the interior of duplicates, you can try the next code, also very fast. It will also return in a newly created sheet, but only for testing reason. If it does what you want, the code can be easily adapted to overwrite the existing range of the active sheet:
Sub CombineDuplicatesKeepAll()
Dim LROW As Long, arrA, arrR(14), arrF, dict As New Scripting.Dictionary
Dim sh As Worksheet, resSh As Worksheet, i As Long, j As Long, arrFin, firstR As Long
Dim rngCol As Range, k As Long
Set sh = Worksheets("Material Planning")
LROW = sh.cells(rows.Count, 1).End(xlUp).row
firstR = 4 'first row of the range to be processed
arrA = sh.Range("A" & firstR & ":N" & LROW).value 'place the range to be processed in an array
ReDim arrFin(1 To UBound(arrA), 1 To UBound(arrA, 2)) 'set the final array at the same dimensions
For i = 1 To UBound(arrA) 'iterate between the array elements
If Not dict.Exists(arrA(i, 1)) Then 'if not a dictionary key as value in column A:A (array column 1):
arrR(0) = sh.Range("A" & i + firstR - 1).Address 'place the cell address like forst dictionary item array element
arrR(1) = i 'the array second element will be the array row (to update it later)
arrFin(i, 1) = arrA(i, 1) 'first element of the final array, on i row will be the first column value
For j = 2 To 14
arrR(j) = arrA(i, j) 'input the rest of the row values in the array to be the dictionary item
arrFin(i, j) = arrA(i, j) 'place the same values in the final array
Next j
dict.Add arrA(i, 1), arrR 'add the array built above like dictionary item
Else
arrR(0) = dict(arrA(i, 1))(0) 'keep the same call address like the first element of the array to be input as item
arrFin(i, 1) = arrA(i, 1) 'place the value in column A:A in the first column of the final array
arrR(1) = dict(arrA(i, 1))(1) 'keep the row of the first dictionary key occurrence
For j = 2 To 14 'fill the array with the values of all row columns
If j <= 9 Then 'for first 9 columns keep their value
arrR(j) = dict(arrA(i, 1))(j)
Else 'for the rest (J to N) add the existing value (in dictionary) to the cells value
arrR(j) = dict(arrA(i, 1))(j) + arrA(i, j)
End If
arrFin(i, j) = arrA(i, j) 'fill the final array with the row data
Next j
dict(arrA(i, 1)) = arrR 'place the array like dictionary item
If rngCol Is Nothing Then 'if range to be colored does not exist, create it:
Set rngCol = sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1)
Else 'if it exists, make a Union between existing and the new one:
Set rngCol = Union(rngCol, sh.Range("A" & i + firstR - 1 & ":N" & i + firstR - 1))
End If
End If
Next i
'adapt te final array rows which used to be the first occurrence of the same dictionary key:
For i = 0 To dict.Count - 1
k = dict.items(i)(1) 'extract the previously memorized row to be updated
For j = 2 To 14 'adapt the row content, for the row range equivalent columns
arrFin(k, j) = dict.items(i)(j)
Next
Next i
'just for testing, paste the result in a new added sheet.
'If everything OK, the code can drop the value in the active sheet
Set resSh = Worksheets.Add(After:=sh)
'drop the array content at once:
resSh.Range("A4").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
If Not resSh Is Nothing Then _
resSh.Range(rngCol.Address).Interior.Color = vbBlack 'color the interior of the next occurrences
End Sub
I tried commenting the code lines, in a way to be easily understood. If something unclear, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.
