I have cells values like image below
I need to transform with VBA code like image below
SUM QTY on col3 based on code from col1 where I have same value.
Thank you.
Dim LastRow1 As Long
With ActiveSheet
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim cc As Integer
For cc = 2 To LastRow1
If Cells(cc, 1).Value = Cells(cc - 1, 1).Value Then
Range("C:C").NumberFormat = "0"
Rows(cc 1).Insert Shift:=xlShiftDown
Range("C" & cc 1).Value = "=Sum(C" & cc & ", C" & cc - 1 & ")"
Cells(cc 1, 3).Value = Cells(cc 1, 3).Value
Cells(cc, 1).Select
Selection.Copy
Cells(cc 1, 1).PasteSpecial Paste:=xlPasteValues
Cells(cc, 2).Select
Selection.Copy
Cells(cc 1, 2).PasteSpecial Paste:=xlPasteValues
Cells(cc, 4).Select
Selection.Copy
Cells(cc 1, 4).PasteSpecial Paste:=xlPasteValues
Rows(cc).EntireRow.Delete
Rows(cc - 1).EntireRow.Delete
End If
Next cc
CodePudding user response:
Please, use the next code. It uses a dictionary to extract the unique keys, cumulate the values in the third columns and build a Union
range (for the same keys, except the first occurrence) to delete the unnecessary rows, at the end. The code only selects the rows in discussion. If processing works well, you should replace in the last code line Select
with Delete
:
Sub MergeValues()
Dim sh As Worksheet, lastR As Long, arr, arrIt, i As Long, Rngdel As Range, dict As Object
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A2:C" & lastR).Value2 'place the range in an array, for aster iteration/processing
Set dict = CreateObject("Scripting.Dictionary") 'set the necessary dictionary
For i = 1 To UBound(arr) 'iterate between the array rows
If Not dict.exists(arr(i, 1)) Then
dict.Add arr(i, 1), Array(i, arr(i, 3)) 'add the code as key, then the array row number (to adapt) and value of third column
Else
arrIt = dict(arr(i, 1)) 'extract the dictionary item array
arrIt(1) = arrIt(1) arr(i, 3)
dict(arr(i, 1)) = arrIt 'place back the processed array
addToRange Rngdel, sh.Range("A" & i 1)
End If
Next i
'update the array with cumulated quantities
For i = 0 To dict.count - 1
arr(dict.Items()(i)(0), 3) = dict.Items()(i)(1)
Next i
'drop the updated array content:
sh.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value2 = arr
If Not Rngdel Is Nothing Then Rngdel.EntireRow.Select 'if it processed correctly, you should replace here Select with Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range) 'function to create the Union range (to delete the necessary rows)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub