Add a new row based on Unique value and delete old

[Chandresh]

Hi All,

First time I am coming to this situation were I don't have any idea how to write a macro for below situation.

1) Unique id is in Column B.
2) Amount is in column C.
3) date of transaction is in column A

I need a macro which will add the amount based on unique ID and create new rows which will have the following and delete old rows.
- last date in date column
- ID in particulars column
- amount in amount column.

Date	Particulars	Amount
23-Jul-18	ABC	-3,36,000
24-Jul-18	ABC	78,000
25-Jul-18	ABC	48,000
26-Jul-18	ABC	54,000	-1,56,000
23-Jul-18	XYZ	-3,36,000
24-Jul-18	XYZ	2,27,800
25-Jul-18	XYZ	98,000
25-Jul-18	XYZ	1,000
26-Jul-18	XYZ	54,000	44,800

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

my output should be as shown below:

Date	Particulars	Amount
26-Jul-18	ABC	-156000
26-Jul-18	XYZ	44800

<colgroup><col><col><col></colgroup><tbody>
</tbody>

 

[Fluff]

How about

Sub SumDupes()
   Dim Cl As Range
   Dim Tmp1 As Variant, Tmp2 As Variant
   Dim Itm As Variant
   Dim i As Long
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Array(Cl.Offset(, -1).Value, Cl.Value, Cl.Offset(, 1).Value)
         Else
            Tmp2 = .Item(Cl.Value)(2) + Cl.Offset(, 1).Value
            If .Item(Cl.Value)(0) < Cl.Offset(, -1).Value Then Tmp1 = Cl.Offset(, -1).Value Else Tmp1 = .Item(Cl.Value)(0)
            .Item(Cl.Value) = Array(Tmp1, Cl.Value, Tmp2)
         End If
      Next Cl
      Range("A1").CurrentRegion.Offset(1).ClearContents
      i = 1
      For Each Itm In .items
         i = i + 1
         Range("A" & i).Resize(, 3).Value = Itm
      Next Itm
   End With
End Sub

 

[Chandresh]

thank u very much

 

[Fluff]

You're welcome

 

[Chandresh]

My data columns have increased I have edited the code however I am not getting the output in correct column...
- product id coming in column2(it should come (below product)
- Quantity coming in column3(it should come (below Quantity)

Output

Transaction Date

Column2

Column3

Product

Column5

Column6

Column7

Column8

Column9

Column10

Column11

Column12

Quantity

Column14

26-Jul-18

ABC

-156000

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

26-Jul-18

XYZ

159300

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

#N/A

New Data

Transaction Date

Column2

Column3

Product

Column5

Column6

Column7

Column8

Column9

Column10

Column11

Column12

Quantity

Column14

23-Jul-18

ABC

-336000

24-Jul-18

ABC

78000

25-Jul-18

ABC

48000

26-Jul-18

ABC

54000

23-Jul-18

XYZ

-10800

24-Jul-18

XYZ

62100

25-Jul-18

XYZ

36000

26-Jul-18

XYZ

72000

<colgroup><col><col><col><col><col><col><col><col span="2"><col><col><col><col><col></colgroup><tbody>
</tbody>

code :
Sub SumDupes()
Dim Cl As Range
Dim Tmp1 As Variant, Tmp2 As Variant
Dim Itm As Variant
Dim i As Long
Sheets("Partly Unrealised").Select
With CreateObject("scripting.dictionary")
For Each Cl In Range("d2", Range("d" & Rows.Count).End(xlUp))
If Not .exists(Cl.Value) Then
.Add Cl.Value, Array(Cl.Offset(, -3).Value, Cl.Value, Cl.Offset(, 9).Value)
Else
Tmp2 = .Item(Cl.Value)(2) + Cl.Offset(, 9).Value
If .Item(Cl.Value)(0) < Cl.Offset(, -3).Value Then Tmp1 = Cl.Offset(, -3).Value Else Tmp1 = .Item(Cl.Value)(0)
.Item(Cl.Value) = Array(Tmp1, Cl.Value, Tmp2)
End If
Next Cl
Range("A1").CurrentRegion.Offset(1).ClearContents
i = 1
For Each Itm In .items
i = i + 1
Range("A" & i).Resize(, 13).Value = Itm
Next Itm
End With
End Sub


- could you please help

Thanks
Chandresh

 

[Fluff]

You just need to change the last part to

   For Each Itm In .items
      i = i + 1
      Range("D" & i).Value = Itm(1)
      Range("A" & i).Value = Itm(0)
      Range("M" & i).Value = Itm(2)
   Next Itm