Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

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


Hoping someone here can help.

Attached is an example of the table I am using (these are parts imported into Excel from PlanSwift) Before entering them into my quoting software, i need to combine like items to simplify the quote.

Is there a way, using macros, to search for similar items, add the quantities of similar items and combine into one line with the SUM, Units and Item # remaining (While then deleting the other, now redundant, rows)?

For further reference, any and all projects will use the same table headers and columns, so one macro should work for every project.

If I were to go further, is it possible to run the macro ONLY on a user highlighted/select area?

Any help is appreciated

CLARIFICATION - Correct, I have little knowledge of VBA but am not unfamiliar and am trying to learn more.

I need to find like items in Column B and add the Quantities in Column C - combined into one line. Columns D and E will always be the same for like items from Column B, so Columns D and E needs to remain for the one row once combined. All rows that are like items should be deleted, less the one with the total for that item. (F and G will likely always be blank)

When running on a user selected area, all others rows are ignored. (This should allow for it to be run in different portions of the project without it pulling from the entire project as some phases may have similar items as other phases but need to remain separate.)

Any rows Label "G" under the Type column are also ignored and remain. The idea is under these headings, like items get grouped together, summed and put into one line.

This is a small sample and yes could potential run on dozens if not hundreds of lines depending on project size.

I hope this helps :S



Hi Patrick and welcome to the Forum 

The answer is (or will be) "yes" but am I right to guess your experience of VBA is nothing or limited? 

To get an answer (from me or others) you need to clarify your question first (by editting it, not replying to this)...

Do you mean to find all like items (under column B) and add the quantities under column C less any orders under F? Giving just summary lines (or leaving the individual rows still showing, for audit or planning purposes say)? If doing it with a selected area, are unselected rows just ignored? Is this a representative size for a project or might you have hundered of lines to group? What is to happen with rows with no quantiities (like WATERMAIN in your file) and can there be several such- was your idea of using selections to group/summarise the selected sub-components under such a heading?

Are you currently doing this manually using sort and SUBTOTAL (on change of Name)?

Please remember to clarify each point. Thanks in advance
John_Ru (rep: 4332) Oct 5, '22 at 3:57 pm
Thanks John, edited the post. Trying to put my mental map into words :S
PCarde (rep: 2) Oct 6, '22 at 10:12 am
Thanks Patrick. Will try to look lster today (my time) 
John_Ru (rep: 4332) Oct 6, '22 at 10:22 am
Please see my Answer, Patrick (and kindly mark it as Selected if it works for you).
John_Ru (rep: 4332) Oct 7, '22 at 1:12 pm
Add to Discussion


Selected Answer


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)
    ' 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
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.




If this works well for you, please mark my Answer as Selected (in accordance with the Forum rules) 
John_Ru (rep: 4332) Oct 10, '22 at 2:10 pm
John, pardon my ignorance :) there is a runtime error 13: missmatch showing when 'replace values
temparr (1) = temparr(1) + .cells(i,3).Value
PCarde (rep: 2) Oct 11, '22 at 12:31 pm

My file works fine, without the error. I suspect you copied the code but omitted the key line (before the sub):
Option Base 1

This means that, in the sub, array elements are indexed from 1 upwards (rather than from the default 0)- which makes it easier for most people to visualise what's happening.

If I comment that out, I get the runtime error 13.

If that's the case, please add the line (before the sub) and try again.

If it works, please mark the answer as Selected. If not, let me know and I'll see if I can think of anything else.
John_Ru (rep: 4332) Oct 11, '22 at 4:37 pm
Did that sort the problem? 
John_Ru (rep: 4332) Oct 12, '22 at 6:09 pm
This worked the way you said, much appreciated. I am off the rest of this week and will begin really putting this to work and testing it out   Much appreciated again John
PCarde (rep: 2) Oct 12, '22 at 6:54 pm
Great! Thanks for selecting my answer and good luck with your testing. 
John_Ru (rep: 4332) Oct 13, '22 at 1:38 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login