how to add/sum two or more rows with similar cell value then put the result on the last row and delete the other similar rows (in VBA)?

gzesasaki

New Member
Joined
Jul 18, 2022
Messages
11
Office Version
  1. 2016
Platform
  1. Windows
Dear Sir/Madam,

can you please help me in resolving my issue on excel and what i am trying to do is to add/sum two or more rows with similar cell value then put the result on the last row (or overwrite the first row with the cell value being summed) and then delete the other rows with cell value being summed.

i am attaching an excel png as sample..
sample.png


" two rows with same value on coumn D ("WALK IN") then cell G should be added. And Im attaching also the required result..

result.png


thank you very much in advance..
gzesasaki
 
Try this version

VBA Code:
Sub Combine_Rows_v3()
  Dim r As Long
  
  Application.ScreenUpdating = False
  Range("A5", Range("P" & Rows.Count).End(xlUp)).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlNo
  For r = Range("A" & Rows.Count).End(xlUp).Row To 6 Step -1
    If Range("D" & r).Value = Range("D" & r - 1).Value Then
      Range("J" & r).Resize(, 2).Copy
      Range("J" & r - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
      Range("P" & r).Copy
      Range("P" & r - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
      Rows(r).Delete
    End If
  Next r
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
Solution

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Try this version

VBA Code:
Sub Combine_Rows_v3()
  Dim r As Long
 
  Application.ScreenUpdating = False
  Range("A5", Range("P" & Rows.Count).End(xlUp)).Sort Key1:=Range("D5"), Order1:=xlAscending, Header:=xlNo
  For r = Range("A" & Rows.Count).End(xlUp).Row To 6 Step -1
    If Range("D" & r).Value = Range("D" & r - 1).Value Then
      Range("J" & r).Resize(, 2).Copy
      Range("J" & r - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
      Range("P" & r).Copy
      Range("P" & r - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
      Rows(r).Delete
    End If
  Next r
  Application.ScreenUpdating = True
End Sub
hi sir,

thank you thank you very much for the code.. it seems all are working perfectly.

(y)(y)(y) hugs ang kisses..
gzesasaki..
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,245
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top