Sum duplicate rows and delete the below one

Panoos64 · Apr 27, 2014

Hi all, I would like to write a macro command so that to sum up duplicate rows and delete the one below searching by col "D" and where there are twice the same reference should be merge to one.The sum up should be in col. "G" and "H". May rows would be more than two so i would like to merge all to one. In F.1. below i show how is my database when i download them and in F.2. is the expected result. I would be great appreciated to any help for my project. Best regards

F.1.
	A	B	C	D	E	F	G	H
1	Debtor ABCD LTD		x
2		31/05/10	x	INV - 1213	Fees	EUR	2.500,00	0,00
3		31/05/10	x	INV - 1213	Expenses	EUR	250,00	0,00
4	Debtor EFGH LTD		x
5		13/03/09	x	INV - 0213	Fees	EUR	1.500,00	0,00
6		13/03/09	x	INV - 0213	Expenses	EUR	150,00	0,00
9		31/12/09	x	REC - 375	Cash-Sofos Sofocleous	EUR	0,00	145,00
10		31/12/09	x	REC - 375	Cash-Sofos Sofocleous	EUR	0,00	1.025,00
11		31/12/09	x	REC - 375	Cash-Sofos Sofocleous	EUR	0,00	55,00


F.2.
	A	B	C	D	E	F	G	H
1	Debtor ABCD LTD		x
2		31/05/10	x	INV - 1213	Fees	EUR	2.750,00	0,00
3	Debtor EFGH LTD		x
4		13/03/09	x	INV - 0213	Fees	EUR	1.650,00	0,00
5		31/12/09	x	REC - 375	Cash-Sofos Sofocleous	EUR	0,00	1.225,00

MickG · Apr 28, 2014

In order for this code to work, I changed the Decimal Points to Commas and and Vice Versa in columns "G" & "H".
If this code in your computer reverts to your country settings it may work for you.!!!!!

Code:

[COLOR=Navy]Sub[/COLOR] MG28Apr33
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] oDta [COLOR=Navy]As[/COLOR] [COLOR=Navy]String[/COLOR]
[COLOR=Navy]Dim[/COLOR] nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Q
[COLOR=Navy]Dim[/COLOR] P
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
  oDta = Join(Application.Index(Dn.Resize(, 3), 1, Array(1, 3)))
  [COLOR=Navy]If[/COLOR] Not Dn = "" [COLOR=Navy]Then[/COLOR]
    [COLOR=Navy]If[/COLOR] Not .Exists(oDta) [COLOR=Navy]Then[/COLOR]
        .Add oDta, Dn
    [COLOR=Navy]Else[/COLOR]
        .Item(oDta).Offset(, 5).Value = Val(.Item(oDta).Offset(, 5).Value) + Val(Dn.Offset(, 5))
        .Item(oDta).Offset(, 6).Value = .Item(oDta).Offset(, 6).Value + Dn.Offset(, 6)
        [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR]
            [COLOR=Navy]Set[/COLOR] nRng = Dn
        [COLOR=Navy]Else[/COLOR]
            [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
 [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]


[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Panoos64 · Apr 28, 2014

Hi MickG, great thanks. It was not necessary to adapt or revert anything on my PC. It works perfectly!! Thanks once again and i wish all the best for the help. Best regard.

Sum duplicate rows and delete the below one

Panoos64

Well-known Member

Excel Facts

MickG

MrExcel MVP

Panoos64

Well-known Member

Similar threads

Forum statistics

Share this page

Sum duplicate rows and delete the below one

Panoos64

Well-known Member

Excel Facts

MickG

MrExcel MVP

Panoos64

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock