VBA - delete duplicates rows, add sum of 1 column

[GeorgeTimes]

Hi Guys,

I need your help with my vba code. I need to locate the duplicates from column A, leave just 1 row of that column and add the sum of column N (the rest of the columns don't matter).

Below it's an example of my raw data (A column and N column)

Account number	Amount
102105709​	82.84​
102099147​	27.36​
102099147​	73.13​
102099146​	54.72​
102099146​	73.13​
102099146​	54.72​
​	36.56​

Above we have 2 duplicates, 102099147 (2x duplicate) and 102099146 (3x duplicate). Need the vba code to result like below:

Account number	Amount
102105709​	82.84​
102099147​	100.49​
102099146​	182.57​

The below vba works and does that, however, if there's a blank cell in column A (see first example, no account number, but value in column N - 36.56), the loop in vba will be an infinite loop. I need your help to fix this as I can't figure it out.




Sub ReorgDataSumCount()


Dim r As Long, lr As Integer, n As Long

Application.ScreenUpdating = False



lr = Cells(Rows.Count, "G").End(xlUp).Row
Range("A2:AG" & lr).Sort key1:=Range("A2"), order1:=2


For r = 2 To lr
n = Application.CountIf(Columns(1), Cells(r, 1).Value)

If n = 1 Then
Range("AH" & r) = 0
ElseIf n > 1 Then
Range("AH" & r) = n - 1
Range("N" & r).Value = Evaluate("=Sum(N" & r & ":N" & r + n - 1 & ")")

Range("A" & r + 1 & ":A" & r + n - 1) = ""
End If
r = r + n - 1
Next r
On Error Resume Next
Range("A2:A" & lr).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Columns("A:AG").AutoFit
Columns("AH:AH").ClearContents

Application.ScreenUpdating = True
End Sub

 

[GeorgeTimes]

Here's an alternative (probably simpler). This will be my last post for the night

Option Explicit
Sub GeorgeTimes_2()
    Dim ws As Worksheet, LRow As Long, LCol As Long
    Set ws = Worksheets("Sheet1")   '<<< change to suit actual sheet name
    Application.ScreenUpdating = False
   
    LRow = Cells.Find("*", , xlFormulas, , 1, 2).Row
    LCol = Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
   
    ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range("A1"), order1:=1, Header:=1
   
    With ws.Range(ws.Cells(2, LCol), ws.Cells(LRow, LCol))
        .FormulaR1C1 = "=IF(RC1="""",RC14,SUMIF(R2C1:R" & LRow & "C1,RC1,R2C14:R" & LRow & "C14))"
        .Value = .Value
        .Copy ws.Range("N2")
    End With
   
    ws.Columns(LCol).EntireColumn.Delete
    LRow = ws.Cells(Rows.Count, 1).End(3).Row
   
    ws.Range("A1:AG" & LRow).RemoveDuplicates Columns:=1, Header:=xlYes
    LRow = Cells.Find("*", , xlFormulas, , 1, 2).Row
    ws.Range("B1", ws.Cells(LRow, 2)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    Application.ScreenUpdating = True
End Sub

Thank you Kevin. I really appreciate it. Can't thank you enough for this

 

[kevin9999]

Thank you Kevin. I really appreciate it. Can't thank you enough for this

Your more than welcome George, and thanks for the feedback.