Sum Values based on Duplicates - VBA

Question

I am looking for a VBA solution to be able to:

1. Look for duplicated values in column "A" and format. (Possible with the code below)
2. With each subsequent duplicate found, the code should sum all the values from Columns "J" through "N" on the first value and fill the duplicated cell black (help)

Sub CombineDuplicates()

Dim Cell As Variant
Dim PList As Range

lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row

Set PList = Worksheets("Material Planning").Range("A4:A" & lRow)

For Each Cell In PList
    
    'Checking whether value in cell already exist in the source range
    If Application.WorksheetFunction.CountIf(PList, Cell) > 1 Then
        
        'Highlight duplicate values in red color
        cRow = Cell.Row
        
        Range("A" & cRow & ":R" & cRow).Interior.Color = RGB(0, 0, 0)
    Else
        Cell.Interior.Pattern = xlNone
    End If
Next


End Sub

Please see the picture for reference. Top is unfiltered data and the bottom is how it should look after the macro runs. Please let me know if you need any more information. Thanks in advance!

Answer 1

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.

Answer 2

Paste Special xlPasteSpecialOperationAdd

• This is a slow solution but may be easily understood.
• It loops through the cells in column A and uses Application.Match to find the index (position) of the first occurrence. If it is not the same then it colors the row and uses PasteSpecial with xlPasteSpecialOperationAdd to add the found values to the values defined by the index.
• Application.ScreenUpdating will speed up the code hiding the on-going 'worksheet dance'.

The Code

Option Explicit

Sub CombineDuplicates()

    Dim ws As Worksheet
    Dim PList As Range
    Dim Cell As Range
    Dim ColsAll As Range
    Dim Cols1 As Range
    Dim Cols2 As Range
    Dim cIndex As Variant
    Dim lRow As Long
    Dim cRow As Long
    
    Set ws = Worksheets("Material Planning")
    lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set PList = ws.Range("A4:A" & lRow)
    
    Set ColsAll = ws.Columns("A:N")
    Set Cols1 = ws.Columns("F:K")
    Set Cols2 = ws.Columns("M:N")
    
    Application.ScreenUpdating = False
        
    For Each Cell In PList.Cells
        cRow = Cell.Row
        cIndex = Application.Match(Cell.Value, PList, 0) + 3
        If cIndex < cRow Then
            ColsAll.Rows(cRow).Interior.Color = RGB(0, 0, 0)
            Cols1.Rows(cRow).Copy
            Cols1.Rows(cIndex) _
                .PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
            Cols2.Rows(cRow).Copy
            Cols2.Rows(cIndex) _
                .PasteSpecial xlPasteValues, xlPasteSpecialOperationAdd
        Else
            ColsAll.Rows(cRow).Interior.Pattern = xlNone
        End If
    Next
    Application.CutCopyMode = False
    ws.Range("A3").Select
    
    Application.ScreenUpdating = True
    
End Sub

Answer 3

Excel has a built-in dedup function. Can you not programmatically copy the 'Simple Description' column at the top to the area underneath, run the dedup on the range containing the copy, then add sumifs to the remaining columns?

The code below creates the bottom table from the top table shown in the picture.

Sub Dedup()

   Range("A1:A9").Copy
   Range("A12").PasteSpecial
   
   Range("B1:E1").Copy
   Range("B12").PasteSpecial
   
   Range("A13:A20").RemoveDuplicates Columns:=1
   
   Range("B13").Formula = "=SUMIF($A$2:$A$9,$A13,B$2:B$9)"
   
   Range("B13").Copy Destination:=Range("B13:E17")

End Sub

Of course, this doesn't maintain the structure with the black rows, but I haven't understood why you need that anyway, since you still have the original table.

And you'll want to do something a little more sophisticated about identifying the correct ranges, particularly for the copied table and when copying the sumif formula from the first cell to the last cell in the range that results from the deduplication. I've kept it simple here for expediency.

Edit: If you want the bottom table to reflect the structure of the original table, you could do a countif on each of the rows in the copy and insert the requisit number of rows that that gives you, and make the new rows black.

Answer 4

So after sitting and brainstorming for a while, I figured that I was trying to overcomplicate things. Thanks to your responses it helped me figure out the direction that I wanted to go. This is the current code that I have which is working flawlessly! It is a little slow, but since I am not going to be shifting through thousands of data points, its is manageable.

I tried to insert value added comments in the code to show the process:

Sub CombineDuplicates()

Dim Cell As Variant
Dim PList As Range

Worksheets("Material Planning").Unprotect

Set ws = Worksheets("Material Planning")
'set last row of working range
lRow = Worksheets("Material Planning").Cells(Rows.Count, 1).End(xlUp).Row


'Toggle parameter. If any cells in range are not colored then it will execute the macro to add common values
If Range("A4:A" & lRow).Interior.ColorIndex = xlColorIndexNone Then
    
    For i = 1 To lRow
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    'since all of the "duplicate" values are listed near each oter, I just need to compare them one after another
    Fst = ws.Range("A" & i)
    Snd = ws.Range("A" & i + 1)
    
    If Snd = Fst Then
    
    'saves the Formula from the cell but just adds the value from the current cell to the next one
    'this way even if there are more than 2 duplicates, the sum will continue on to the next cell
    ws.Range("F" & i + 1).Formula = ws.Range("F" & i + 1).Formula & "+" & ws.Range("F" & i).Value
    ws.Range("G" & i + 1).Formula = ws.Range("G" & i + 1).Formula & "+" & ws.Range("G" & i).Value
    ws.Range("J" & i + 1).Formula = ws.Range("J" & i + 1).Formula & "+" & ws.Range("J" & i).Value
    
    'The whole Row will be filled black so that it is not considered in the analysis
    Range("A" & i & ":U" & i).Interior.Color = RGB(0, 0, 0)
    End If
    Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Else

    'if there is already formatting on any cells in column A, this will remove the filled black formatting from all cells in the range
    Range("A4:U" & lRow).Interior.Color = xlNone
    ws.Range("F4:N" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
    ws.Range("P4:U" & ws.Cells(Rows.Count, 6).End(xlUp).Row).FillDown
     
End If
Application.ScreenUpdating = True
Application.EnableEvents = True

Worksheets("Material Planning").Protect
End Sub

Thank you all for your help and advice on this!

Answer 5

This would be a simple, but probably not the fastest way of doing it:

Sub CombineDuplicates()

Dim Cell As Variant, PList As Range
Dim i As Long, j As Long, a As Long
Dim k(7) As Long
LRow = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 4 To LRow
    Erase k
    If Not Range("A" & i).Interior.Color = RGB(0, 0, 0) Then
        For j = i + 1 To LRow
            If Range("A" & i).Value = Range("A" & j).Value Then
                For a = 0 To 7
                    k(a) = k(a) + Cells(j, a + 2)
                Next a
                Range("A" & j & ":N" & j).Interior.Color = RGB(0, 0, 0)
            End If
        Next j
        For a = 0 To 7
            Cells(i, a + 2) = Cells(i, a + 2) + k(a)
        Next a
    End If
Next i

End Sub

Essentially, for each row that isn't black (to avoid unnessecary calculaitons) we loop the rest of the range to look for duplicats. Add the values in the array k and keep looking.
Then we end the subloop by adding the number from the array to the current row, and keep going.
Should probably add something to clear the interior formatting first, for subsequent runs.

Answer 6

This uses a dictionary to detect duplicates and a class to keep your data organized

Place this piece inside of a class module:

Option Explicit

Private data As datasum
Private prow As Long
Private ptargetsheet As Worksheet

Private Type datasum
    thirtyday As Long
    threemonth As Long
    expectedusage As Double
    ordertarget As Double
    stock As Long
    avgdayleft As Long
    dayleft As Long
    pending As Long
End Type

Sub initialize(targetsheet As Worksheet, row As Long)
    Set ptargetsheet = targetsheet
    prow = row
End Sub

Sub addData(dataArray As Variant)
    data.thirtyday = data.thirtyday + dataArray(1, 1)
    data.threemonth = data.threemonth + dataArray(1, 2)
    data.expectedusage = data.expectedusage + dataArray(1, 3)
    data.ordertarget = data.ordertarget + dataArray(1, 4)
    data.stock = data.stock + dataArray(1, 5)
    data.avgdayleft = data.avgdayleft + dataArray(1, 6)
    data.dayleft = data.dayleft + dataArray(1, 8)
    data.pending = data.pending + dataArray(1, 9)
End Sub

Sub placeData()
    With ptargetsheet
        .Cells(prow, 6).Value = data.thirtyday
        .Cells(prow, 7).Value = data.threemonth
        .Cells(prow, 8).Value = data.expectedusage
        .Cells(prow, 9).Value = data.ordertarget
        .Cells(prow, 10).Value = data.stock
        .Cells(prow, 11).Value = data.avgdayleft
        .Cells(prow, 13).Value = data.dayleft
        .Cells(prow, 14).Value = data.pending
    End With
End Sub

And this piece in either your sheet module or a regular module:

Option Explicit

Sub CombineDuplicates()
    Dim i As Long
    Dim lRow As Long
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim data As DataClass
    
    With Sheets("Material Planning")
        lRow = .Cells(.Rows.Count, 1).End(xlUp).row
        For i = 4 To lRow
            If Not dict.exists(.Cells(i, 1).Value) Then
                Set data = New DataClass
                data.initialize Sheets("Material Planning"), i
                data.addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
                dict.Add .Cells(i, 1).Value, data
            Else
                dict(.Cells(i, 1).Value).addData .Range(.Cells(i, 6), .Cells(i, 14)).Value
                dict(.Cells(i, 1).Value).placeData
                .Range(.Cells(i, 1), .Cells(i, 14)).Interior.Color = RGB(0, 0, 0)
            End If
        Next i
    End With
        
End Sub