Delete row after summing a range

[Ashrak]

Hy everyone, i will write an example so you could understand me better,
my table looks like this

Article number|description 1|description 2|description 3|Pcs.|
333156| green| good| tall| 200
333156 |green |good| tall| 150
333168 |red |good| small| 500

i need an macro that deletes the rows with same articles for example 333156 but only after summing the pcs:

333156 |green| good| tall| 350
333168 |red |good| small| 500
I found a lot of delete duplicates rows metods but didn't match what i need.

can someone help me?
Thank you,

 

[venkat1926]

original data is in sheet1. copy the data to sheet2 also

now try this macro "test" (the second macro undo is to undo the result of the macro and bring back the data)

Sub test()
Dim data As Range, j As Integer
Worksheets("sheet1").Activate
Set data = Range("A1").CurrentRegion
    data.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
For j = Range("A1").End(xlDown).Row To 2 Step -1
If Left(Cells(j, 1), 5) = "Grand" Then Cells(j, 1).EntireRow.Delete
If Right(Cells(j, 1), 5) = "Total" Then
If Left(Cells(j, 1), 5) <> "Grand" Then
Range(Cells(j - 1, "B"), Cells(j - 1, "D")).Copy Cells(j, 1).Offset(0, 1)
Cells(j, "E").Copy
Cells(j, "E").PasteSpecial Paste:=xlPasteValues
End If
End If
If IsNumeric(Cells(j, 1)) Then Cells(j, 1).EntireRow.Delete
Next j
Set data = ActiveSheet.UsedRange
data.ClearOutline
End Sub

Sub undo()
Worksheets("sheet1").Cells.Clear
Worksheets("sheet2").Cells.Copy Worksheets("sheet1").Range("A1")
End Sub

 

[Ashrak]

Thank you for your help, when i run the macro returns error, bad syntax

"data.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(5), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True"

do you know why?

 

[Ashrak]

if you think it's more easy if the table looks like this
333186 20
333159 80
333186 90

and after running macro will return


333186 110
333159 90,

it's okay for me , i'll use vlookup after and get to my result...
my main concern is that there are no duplicates, and the sum... i tried with subtotal function but returns
333186 Total = 110 and i can't use vlookup because of "total" added after 333186

thank you very much

 

[venkat1926]

the data in sheet 1 (which is copied to sheet 2 also) is like this and the macro works

Excel Workbook
	A	B	C	D	E
1	Article number	description 1	description 2	description 3	Pcs.
2	333156	green	good	tall	200
3	333156	green	good	tall	150
4	333168	red	good	small	500
Sheet1

 

[Ashrak]

it works but returns "333156 total" in first cell

 

[hiker95]

Ashrak,


Sample raw data already sorted and grouped per your screenshot:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K
1	Article number	description 1	description 2	description 3	Pcs.
2	333156	green	good	tall	200
3	333156	green	good	tall	150
4	333168	red	good	small	500
5
Sheet1

After the macro:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K
1	Article number	description 1	description 2	description 3	Pcs.		Article number	description 1	description 2	description 3	Pcs.
2	333156	green	good	tall	200		333156	green	good	tall	350
3	333156	green	good	tall	150		333168	red	good	small	500
4	333168	red	good	small	500
5
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 07/11/2011
' http://www.mrexcel.com/forum/showthread.php?t=563307
Dim LR As Long
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
With Range("F2:F" & LR)
  .FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]&RC[-2]"
  .Value = .Value
End With
Range("A1:D" & LR).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("G1"), Unique:=True
LR = Cells(Rows.Count, 7).End(xlUp).Row
With Range("K2:K" & LR)
  .FormulaR1C1 = "=RC[-4]&RC[-3]&RC[-2]&RC[-1]"
  .Value = .Value
End With
Range("L1").Value = Range("E1").Value
With Range("L2:L" & LR)
  .FormulaR1C1 = "=SUMIF(C[-6],RC[-1],C[-7])"
  .Value = .Value
End With
Columns(6).Clear
Columns(11).Delete
Columns("G:K").AutoFit
Application.ScreenUpdating = True
End Sub

Then run the ReorgData macro.

 

[Ashrak]

Thanks, it works like a charm )