Compile Bill of Materials and Remove Duplicates

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