How to sum values and remove duplicates rows

[Alfi]

Hi All,

I'm trying to remove duplicates and sum values. I have table which is looks like that.

item number	client	Date	Quantity
167​	C10000038	28/01/2022 00:00​	3​
600831​	C10008630	27/01/2022 00:00​	1​
600831​	C10008630	27/01/2022 00:00​	48​
600827​	C10008630	28/01/2022 00:00​	1​
950114​	C10008630	28/01/2022 00:00​	3​
1357​	C10008630	28/01/2022 00:00​	2​
600827​	C10008630	28/01/2022 00:00​	1​
950115​	C10008630	27/01/2022 00:00​	1​
600831​	C10008630	27/01/2022 00:00​	1​

please see code what i use below, it doesn't work properly, I have already blow my mind how to solve it.

Sub CombineDupes()
    
    Dim x       As Long
    Dim r       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Const DELIM As String = "|"
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    x = Cells(Rows.Count, 1).End(xlUp).Row
    arr = Cells(1, 1).Resize(x, 4).Value
    
    For x = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.exists(arr(x, 1)) Then
            arr(x, 4) = arr(x, 4) + CDbl(Split(dic(arr(x, 1)), DELIM)(2))
        Else
            dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4)
        End If
        dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4)
    Next x
    
    r = UBound(arr, 1) + 2
    
    Application.ScreenUpdating = False
    
    Cells(r, 1).Resize(, 4).Value = Cells(1, 1).Resize(, 4).Value
    r = r + 1
    
     For x = 0 To dic.Count - 1
        Cells(r + x, 1).Value = dic.keys()(x)
        Cells(r + x, 2).Resize(, 3).Value = Split(dic.items()(x), DELIM)
        Cells(r + x, 4).Value = CDbl(Cells(r, 4).Value)
    Next x
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set dic = Nothing
    
End Sub

 

[Anthony47]

Could you please explain which column/columns need to be checked to determine that there is a duplication and where you wish to create the summary?
Also, did you already consider using a pivot-table?
Bye

 

[Alfi]

I have used Pivot table before but I'm trying to automate the process. basically my primary fields are item number, client, date, the result what im trying to reach is no duplicates and if there some duplicates then sum the quantity and remove the row.

 

[Anthony47]

You didn't explained how to check for duplicated items, so let me guess that the key be "ItemNumber & Client".
Also I assume that you wish not to destroy the starting data and thus prefer creating the summary in a different worksheet; in case that the key "ItemNumber & Client" already exists then the new quantity is added to the already stored one, and the Date is updated with the new date.

Under these assumptions then try the following macro:

Sub MkSummary()
Dim sSh As Worksheet, dSh As Worksheet
Dim dNext As Long, I As Long, J As Long, wArr, oArr()
Dim myDic As Object, myK As String, NextO As Long
'
Set sSh = Sheets("Foglio1")         '<<< The sheet with the starting info
Set dSh = Sheets("Foglio2")         '<<< The sheet where the summary will be created
'
wArr = sSh.Range("A1").CurrentRegion.Value
ReDim oArr(1 To UBound(wArr), 1 To UBound(wArr, 2))
Set myDic = CreateObject("Scripting.Dictionary")
dSh.Range("A1").CurrentRegion.ClearContents             '!!! Clear the output area
NextO = 1
For I = 1 To UBound(wArr)
    myK = wArr(I, 1) & "#" & wArr(I, 2)
    If myDic.Exists(myK) Then
        oArr(myDic.Item(myK), 4) = oArr(myDic.Item(myK), 4) + wArr(I, 4)
        oArr(myDic.Item(myK), 3) = wArr(I, 3)
    Else
        myDic.Add (myK), NextO
        For J = 1 To UBound(wArr, 2)
            oArr(NextO, J) = wArr(I, J)
        Next J
        NextO = NextO + 1
    End If
Next I
dSh.Range("A1").Resize(NextO, UBound(oArr, 2)).Value = oArr
ReDim oArr(1, 1)
End Sub

The lines marked <<< need to be adapted to your situation; beware that the output sheet will be cleared before the summary is created. If you need that new daily data be added to an already existing Summary then the code need to be slightly modified.

In case you only need to look at ItemNumber, then consider creating the list of rows using the function UNIQUE and then conventional CountIf or CoutIfs or SumIf or SumIfs to calculate the summary data.

Waiting for your feedback..

 

[Alfi]

Thats an amazing thanks you are life saver!

The keys are ItemNumber & Client & Date.

I'm not too sure how to work with arrays and add new key, please see is that the right changes? I have added New variable DT-Date. Also i renamed variables as I-IItemNUM, J-ClientNUM.
And i have changed the Quantity column on 6 coz I have some additional information in my table but its not a key. And it works, im so happy to see that it works.

Sub MkSummary()
Dim sSh As Worksheet, dSh As Worksheet
Dim dNext As Long, IItemNUM As Long, ClientNUM As Long, DT As Long, wArr, oArr()
Dim myDic As Object, myK As String, NextO As Long
'
Set sSh = Sheets("MASTERDATA")         '<<< The sheet with the starting info
Set dSh = Sheets("MASTERDATA_FINAL")         '<<< The sheet where the summary will be created
'
wArr = sSh.Range("A1").CurrentRegion.Value
ReDim oArr(1 To UBound(wArr), 1 To UBound(wArr, 2))
Set myDic = CreateObject("Scripting.Dictionary")
dSh.Range("A1").CurrentRegion.ClearContents             '!!! Clear the output area
NextO = 1
For IItemNUM = 1 To UBound(wArr)
    myK = wArr(IItemNUM, 1) & "#" & wArr(IItemNUM, 2)
    If myDic.Exists(myK) Then
        oArr(myDic.Item(myK), 6) = oArr(myDic.Item(myK), 6) + wArr(IItemNUM, 6)
        oArr(myDic.Item(myK), 3) = wArr(IItemNUM, 3)
    Else
        myDic.Add (myK), NextO
        For ClientNUM = 1 To UBound(wArr, 2)
            oArr(NextO, ClientNUM) = wArr(IItemNUM, ClientNUM)
        Next ClientNUM
        'third key
        For DT = 1 To UBound(wArr, 3) ' i select 3rd column in array ??
            oArr(NextO, DT) = wArr(IItemNUM, ClientNUM, DT)
        Next DT
        
        NextO = NextO + 1
    End If
Next IItemNUM
dSh.Range("A1").Resize(NextO, UBound(oArr, 2)).Value = oArr
ReDim oArr(1, 1)
End Sub

 

[Anthony47]

To avoid misunderstandings, is it correct that modified macro works as needed?
Bye

 

[bebo021999]

With source in sheet MasterData, result in sheet MasterData_Final:

Option Explicit
Sub dupplicate()
Dim dic As Object
Dim Lr&, qty&, k&, key, cell As Range, st As String, arr() As Variant
Dim ws As Worksheet
Set ws = Worksheets("MASTERDATA")
Set dic = CreateObject("scripting.dictionary")
Lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim arr(1 To 100, 1 To 4)
    For Each cell In ws.Range("A2:A" & Lr)
        st = cell & "|" & cell.Offset(0, 1) & "|" & cell.Offset(0, 2)
        If Not dic.exists(st) Then
            dic.Add st, st & "|" & cell.Offset(0, 3).Value
        Else
            For Each key In dic.keys
                If st = key Then
                    qty = Split(dic(key), "|")(3)
                    qty = qty + cell.Offset(0, 3).Value
                    dic(st) = st & "|" & qty
                End If
            Next
        End If
    Next
    For Each key In dic.keys
        k = k + 1
        arr(k, 1) = Split(dic(key), "|")(0)
        arr(k, 2) = Split(dic(key), "|")(1)
        arr(k, 3) = Split(dic(key), "|")(2)
        arr(k, 4) = Split(dic(key), "|")(3)
    Next
    With Worksheets("MASTERDATA_FINAL")
        .Range("A1:D1").Value = ws.Range("A1:D1").Value
        .Range("A2").Resize(UBound(arr), 4).Value = arr
    End With
End Sub