This example builds upon the methods of finding duplicate data. See https://pearlsnake.com/2019/06/20/find-and-delete-rows-with-duplicate-data/
In order for a row to be complied, Column A, E and K have to match the data in other rows. After running the example the data was been reduced from 35 rows to 30 rows. This helps purchasing departments so they don’t have to order the same thing twice, but still end up with the same amount of quantities.


Option Explicit Dim endrow As Long Dim irow As Long Sub copy_MRL() Dim ws As Worksheet Dim divisorTape As Double Dim isvaluenewcollectionitem3 As New Collection Dim currentcollectioncount As Long Dim Nrows As Long Dim arow As Long Dim brow As Long Dim CellVal As Variant Dim Btn As Button Dim sht1 As Worksheet Dim rng As Range, cell As Range Application.ScreenUpdating = False endrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row Range("a15:k" & endrow).Interior.Pattern = xlNone 'clear all the highlights Call findduplicates Sheets("BillofMaterials").Copy Before:=Sheets(1) For Each Btn In ActiveSheet.buttons 'delete the buttons on the new sheet Btn.Delete Next Btn endrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row Call findduplicates ReDim mrl_duplicates_array(1 To endrow, 1 To 11) arow = 1 currentcollectioncount = 0 For irow = 2 To endrow If Range("A" & irow).Interior.Color = 65535 Then CellVal = Range("A" & irow).Value & Range("k" & irow).Value & Range("E" & irow).Value On Error Resume Next isvaluenewcollectionitem3.Add CellVal, Chr(34) & CellVal & Chr(34) On Error GoTo 0 If isvaluenewcollectionitem3.Count > currentcollectioncount Then currentcollectioncount = isvaluenewcollectionitem3.Count mrl_duplicates_array(arow, 1) = Cells(irow, "A").Value 'part number mrl_duplicates_array(arow, 4) = 0 'qty mrl_duplicates_array(arow, 5) = Cells(irow, "E").Value 'desc mrl_duplicates_array(arow, 11) = Cells(irow, "K").Value 'notes arow = arow + 1 End If End If Next irow arow = 1 Do Until mrl_duplicates_array(arow, 1) = "" For brow = 2 To endrow If Cells(brow, "A") & Cells(brow, "k") & Cells(brow, "e") = mrl_duplicates_array(arow, 1) _ & mrl_duplicates_array(arow, 11) & mrl_duplicates_array(arow, 5) Then mrl_duplicates_array(arow, 4) = mrl_duplicates_array(arow, 4) + Cells(brow, "D") End If Next brow arow = arow + 1 Loop Nrows = UBound(mrl_duplicates_array, 1) - LBound(mrl_duplicates_array, 1) Range(Cells(endrow + 3, "A"), Cells(endrow + 3 + Nrows, "K")) = mrl_duplicates_array endrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row For irow = endrow To 15 Step -1 If Range("A" & irow) = "" Or Len(Trim(Range("A" & irow))) = 0 Then Rows(irow).Delete 'delete the blank rows End If Next irow endrow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row For irow = endrow To 15 Step -1 If Range("A" & irow).Interior.Color = 65535 Then Rows(irow).Delete 'delete the duplicates End If Next irow With ActiveSheet 'sort the data according to the notes column .Range("a14:k14").AutoFilter .AutoFilter.Sort.SortFields.Clear .AutoFilter.Sort.SortFields.Add Key:=Range("k14"), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .AutoFilter.Sort.Header = xlYes .AutoFilter.Sort.MatchCase = False .AutoFilter.Sort.Orientation = xlTopToBottom .AutoFilter.Sort.SortMethod = xlPinYin .AutoFilter.Sort.Apply .Range("a14:k14").AutoFilter endrow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row .Range("a15:k15").Copy 'format the mrl .Range("a16:k" & endrow).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False .Columns("A:k").Columns.AutoFit 'autofit the columns of the new sheet End With End Sub Private Sub findduplicates() Dim isvaluenewcollectionitem As New Collection Dim isvaluenewcollectionitem2 As New Collection Dim currentcollectioncount As Long Dim CellVal As Variant For irow = 2 To endrow If Range("A" & irow) = "" Or Len(Trim(Range("A" & irow))) = 0 Then Else CellVal = Range("A" & irow).Value & Range("k" & irow).Value & Range("E" & irow).Value On Error Resume Next isvaluenewcollectionitem.Add CellVal, Chr(34) & CellVal & Chr(34) On Error GoTo 0 If isvaluenewcollectionitem.Count > currentcollectioncount Then currentcollectioncount = isvaluenewcollectionitem.Count Else Range(Cells(irow, "A"), Cells(irow, "K")).Interior.Color = 65535 CellVal = Range("A" & irow).Value & Range("k" & irow).Value & Range("E" & irow).Value On Error Resume Next isvaluenewcollectionitem2.Add CellVal, Chr(34) & CellVal & Chr(34) On Error GoTo 0 End If End If Next irow currentcollectioncount = 0 For irow = 2 To endrow If Range("A" & irow) = "" Or Len(Trim(Range("A" & irow))) = 0 Then Else CellVal = Range("A" & irow).Value & Range("k" & irow).Value & Range("E" & irow).Value On Error Resume Next isvaluenewcollectionitem2.Add CellVal, Chr(34) & CellVal & Chr(34) On Error GoTo 0 If isvaluenewcollectionitem2.Count > currentcollectioncount Then currentcollectioncount = isvaluenewcollectionitem2.Count Else Range(Cells(irow, "A"), Cells(irow, "K")).Interior.Color = 65535 End If End If Next irow End Sub