Search/Combine Like Items in Table (Non-Adjacent)

Patrick

Here's an answer based on using a VBA scripting dictionary. Pick some cells on Sheet1 (say B3:B23) and click the green button labelled "Collate parts (on selected rows)"  and the code below will run to produce results onSheet2 (please check they work, noting I added Order values -in yellow in column F- for text purposes). If you don't select cells on more than one row, it will just sort all data on Sheet1.

The code is commented so you can see what is happening:

Option Base 1
Sub GroupAllOrSelectedItems()

Dim SortRng As Range, LstRw As Long, PartDict As Object

' determine last used row in column B
LstRw = Range("B" & Rows.Count).End(xlUp).Row

' see if the user wants only selected rows
If Selection.Rows.Count > 1 Then
    'if so, set range to use only selected rows
    Set SortRng = Intersect(Columns("A:G"), Selection.EntireRow)
    Else
    ' otherwise set range to all used rows"
    Set SortRng = Range("A2:G" & LstRw)
End If

Set PartDict = CreateObject("Scripting.Dictionary")

'create a dictionary with B as the key and values from column C to Fas dictionary value
For i = 1 To SortRng.Rows.Count
   With SortRng
    If Len(.Cells(i, 2)) > 0 Then
         'create dictionary key
          s = Trim(.Cells(i, 2).Value)
         'check if dictionary key exists and if not create a new key with value as address in B
         If Not PartDict.exists(s) Then
            ' make entry as array of value
            PartDict(s) = Array(.Cells(i, 3).Value, .Cells(i, 4).Value, .Cells(i, 5).Value, .Cells(i, 6).Value)
            
            Else ' add values for Qty and Order
            'get the existing array
            TempArr = PartDict.Item(s)
            ' replace values
            TempArr(1) = TempArr(1) + .Cells(i, 3).Value
            If .Cells(i, 6).Value <> "" Then TempArr(4) = TempArr(4) + .Cells(i, 6).Value
            'rewrite dictionary value
            PartDict.Item(s) = TempArr
         End If
     End If
    End With
Next i

' set sorted range to italic
SortRng.Font.Italic = True

'create alphabetical list of dictionary keys
a = mySort(PartDict.keys)

With Sheet2
    .Name = "Grouped items"
    .Range("A1:E1").Value = Sheet1.Range("B1:F1").Value
    ' determine last used row in column A
    LstRw = .Range("A" & .Rows.Count).End(xlUp).Row
    ' write summed quantities
    For n = 1 To UBound(a, 1)
        ' write alphabetic keys below existing data
        .Cells(LstRw + n + 1, 1) = a(n)
        TempArr = PartDict(a(n))
        ' write values from dictionary
        For m = 1 To 4
            .Cells(LstRw + n + 1, m + 1) = TempArr(m)
        Next m
    Next n
    ' autofit columns
    .Columns("A:E").AutoFit
End With
' clear dictionary
Set PartDict = Nothing
'tell user
MsgBox "Grouped results written to second sheet"

End Sub

It calls a bubble sort function to sort the dictionary keys alphabetically:

Function mySort(a)
Dim p As Long, q As Long, temp
For p = LBound(a) To UBound(a) - 1
    For q = p + 1 To UBound(a)
        If a(p) > a(q) Then
            temp = a(p): a(p) = a(q)
            a(q) = temp
        End If
    Next q
Next p

mySort = a
End Function

It writes the grouped data to the end of the (initially empty) second sheet (and renames it) plus sets the font of the grouped data (on sheet1) to italics, to show you've already worked on that.

Note that it will work with tens or hundreds of lines of data on sheet1 (but it might be a little slow with thousands- it's not optimised for speed).

Please give this a whirl and let me have your comments. It isn't quite finished and might be done using sort/ add subtotals (but I don't have the time to start again!).

Hope this helps.