VBA check column for duplicate products and sum their quantity in another column

[matija385hr]

Hi all,

I have in 4 columns by order: Order number, Product, Quantity, Note.

What I need to do is to check in Sheet "Products" column B (Product) for duplicates, sum their quantities (column C) and put them in another sheet "Group", but only if column D (Notes) is empty. If there is something in Column D, it should be pasted to another sheet "Group" (product, quantity and note).

I found this code from MickG, but don't know how to alter it to fit my needs

Thank you in advance

Sub MG14May26
Dim Rng As Range, Dn As Range, n As Long, nRng As Range, nCol As Long
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
nCol = ActiveSheet.Cells(1).CurrentRegion.Columns.Count
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Dn
    Else
        If nRng Is Nothing Then Set nRng = _
        Dn Else Set nRng = Union(nRng, Dn)
        .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
    End If
Next
For Each Dn In nRng
    Dn.Resize(, nCol).ClearContents
Next Dn
Rng.Resize(, nCol).Sort Key1:=Range("A2"), Order1:=xlAscending
End With
End Sub

 

[JLGWhiz]

Please copy the code exactly as you are using it and paste into the thread reply pane. I want to compare it to my code.

 

[matija385hr]

Hi,

here is the code:

Sub t()
Dim c As Range, qty As Long, sh1 As Worksheet, sh2 As Worksheet, lr As Long, rng As Range, fn As Range, adr As String
Set sh1 = Sheets("Products")
Set sh2 = Sheets("Group")
    With sh1
        lr = .Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
        Set rng = .Range("B3", .Cells(Rows.Count, 2).End(xlUp))
        rng.AdvancedFilter xlFilterCopy, , .Cells(lr + 2, 1), True
        For Each c In .Cells(lr + 2, 1).CurrentRegion.Offset(1)
            If c <> "" Then
                Set fn = rng.Find(c.Value, , xlValues, xlWhole)
                    If Not fn Is Nothing Then
                        adr = fn.Address
                        Do
                            If fn.Offset(, 2) = "" Then
                                qty = qty + fn.Offset(, 1).Value
                            End If
                            Set fn = rng.FindNext(fn)
                        Loop While fn.Address <> adr
                        sh2.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
                        sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = qty
                    End If
                    qty = 0
            End If
        Next
        For Each c In .Cells(lr + 2, 1).CurrentRegion.Offset(1)
            If c <> "" Then
                Set fn = rng.Find(c.Value, , xlValues, xlWhole)
                    If Not fn Is Nothing Then
                        adr = fn.Address
                        Do
                            If fn.Offset(, 2) <> "" Then
                                fn.Resize(, 3).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
                            End If
                            Set fn = rng.FindNext(fn)
                        Loop While fn.Address <> adr
                    End If
            End If
        Next
        .Cells(lr + 2, 1).CurrentRegion.ClearContents
    End With
End Sub

 

[JLGWhiz]

Lets try this mocification and see what happens. Replace this

sh2.Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = qty

With this

If qty > 0 Then
       sh2.Cells(Rows.Count, 1).End(xlUp)(2) = fn.Value  
       sh2.Cells(Rows.Count, 1).End(xlUp).Offset(, 1) = qty
End If

But I don't know why qty would be 0 at that point, although it appears that it is in your file. I cannot duplicate the condition, ergo the quick fix.

 

[JLGWhiz]

I have identified the problem and the modified code in Post #13 will fix it. I am still trying to understand the logic behind it so cannot give a good explatnation at this point, except to say that it involved the Do Loop and FindNext Functions in the first For Each loop. I will have to be careful not to build that trap in the future. If I could have accessed your actual worksheet originally, I would likely have caught that before posting the code. But, I didn't so make the mod in post #13 and it should solve your prolblem.

 

[matija385hr]

Hi JLGWhiz,

Thank you for your help, fix you sent in post #13 was perfect, it solved the problem.

Thank you again for your time and help.

Kind regards,
Matija

 

[JLGWhiz]

Hi JLGWhiz,

Thank you for your help, fix you sent in post #13 was perfect, it solved the problem.

Thank you again for your time and help.

Kind regards,
Matija

You're welcome,
regards, JLG