VBA - delete duplicates rows, add sum of 1 column

GeorgeTimes

New Member
Joined
Jul 22, 2022
Messages
16
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
Platform
  1. Windows
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 numberAmount
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 numberAmount
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
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
How do you want to handle the blank Account numbers - sum them together as one or leave them a separate entries? Or delete those rows?
 
Upvote 0
How do you want to handle the blank Account numbers - sum them together as one or leave them a separate entries? Or delete those rows?
Deal with them as separate account numbers. So leave them as if they have a unique account number. Based on the example provided, I need it to result like below:



102105709
82.84
102099147100.49
102099146
182.57
36.56

If there're multiple blanks in column A (which will 100% be), something like below:


Account numberAmount
102105709
82.84
102099147100.49
102099146
182.57
36.56
1 (second blank)
2 (thrid blank found)

I hope this makes sense.
 
Upvote 0
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 numberAmount
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 numberAmount
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

Just realized I haven't mentioned why I'm using column G to see how many rows there are. In column G, there will always be data, therefore that's how I know 100% how many rows I have. Can't use column A because there will be empty cells
 
Upvote 0
What's between columns A & N? Is there any chance you could provide a small sample of your data using the XL2BB add in?
 
Upvote 0
What's between columns A & N? Is there any chance you could provide a small sample of your data using the XL2BB add in?
Please see attached.

I'm only interested in finding the duplicates in column A, delete the rest of the duplicates and in column N add the sum of those, the rest can be kept the same (i.e If A4 and A5 are duplicates, I want to keep one of them (let's say A4), and in N4 to have the sum of N4 and N5. In J4 and J5 the data will be different (even though A4 and A5 are duplicates) but I can keep either J4 or J5, I don't care about the data from other columns, except for A and N

Copy of Statement.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAG
1Account numberTRX_NUMBERTRX_DATEDUE_DATEBILL_ACTIONCREDITED_INVCompany numberPARTY_NAMEMANTLE_CODEREFERENCEPURCHASE_ORDERCUSTOMER_REFERENCECOMMENTSAMOUNT_DUE_ORIGINALAMOUNT_DUE_REMAININGDISPUTE_AMOUNTPAYMENT_TERMBILL_TO_ADDRESS1BILL_TO_ADDRESS2BILL_TO_ADDRESS3BILL_TO_ADDRESS4BILL_TO_CITYBILL_TO_POSTAL_CODECATEGORYCREATION_DATECREATED_BYPRINT_STATUSOUCOMPANY_NUMSORT_COLUMNCURRENCY_CODERU_NUMBERRIMA_FLAG
2102105709660284906-Sep-2206-Oct-22Invoice1000349571ARG57422500225_1002_S04/05/2017Regular Bill82.8482.8430Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:58BATCH_UK_BILLINGPRINTEDUK1000349571-86185094GBP31671904
3102099148602306706-Sep-2206-Oct-22Invoice1000349571ARG5749.6PP- 09082019Regular Bill27.3627.3630Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177409GBP31671904
4102099147602306606-Sep-2206-Oct-22Invoice1000349571ARG5747.6724- 09082019Regular Bill73.1373.1330Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177408GBP31671904
5102099147602306506-Sep-2206-Oct-22Invoice1000349571ARG5749.624- 09082019Regular Bill54.7254.7230Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177407GBP31671904
6102099146602306406-Sep-2206-Oct-22Invoice1000349571ARG5747.6712072019Regular Bill73.1373.1330Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177406GBP31671904
7102099146602306306-Sep-2206-Oct-22Invoice1000349571ARG5749.612072019Regular Bill54.7254.7230Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177405GBP31671904
8102099146602306206-Sep-2206-Oct-22Invoice1000349571ARG5747.67H- 29052019Regular Bill36.5636.5630Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177404GBP31671904
9602306106-Sep-2206-Oct-22Invoice1000349571ARG5749.6 H- 29052019Regular Bill27.3627.3630Dc/o Data Capture SolutionsPO Box SLOUGHSL3 5XZOKS CONTRACTS06/09/2022 22:49BATCH_UK_BILLINGPRINTEDUK1000349571-86177403GBP31671904
Sheet2
 
Upvote 0
Try this on a copy of your data. It will clear all other columns except A and N. Change the sheet name to suit.

VBA Code:
Option Explicit
Sub GeorgeTimes()
    Dim ar, ar2, ar3, i As Long, n As Long, ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<<< change to suit actual sheet name
    Application.ScreenUpdating = False
    
    'Store the blank Acc. nos in an array
    ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlYes
    Dim LRow1 As Long, LRow2 As Long
    LRow1 = ws.Cells(Rows.Count, 1).End(3).Row + 1
    LRow2 = ws.Cells(Rows.Count, 14).End(3).Row
    ar2 = ws.Range(ws.Cells(LRow1, 14), ws.Cells(LRow2, 14)).Value
    
    'Delete blank Acc. no rows
    ws.Range("A2", ws.Cells(LRow1, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
    'Consolidate duplicates
    ar = Sheet1.Range("A1").CurrentRegion.Offset(1)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ar, 1)
            .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 14)
        Next
        ar = Array(.keys)
        ar3 = Array(.items)
        n = .Count
    End With
    
    'Put values back to sheet
    ws.Range("A1").CurrentRegion.Offset(1).ClearContents
    ws.Range("A2").Resize(n, 1).Value = Application.Transpose(ar)
    ws.Range("N2").Resize(n, 1).Value = Application.Transpose(ar3)
    
    If LRow1 = LRow2 Then
        ws.Cells(n + 1, 14) = ar2
    Else
        ws.Cells(n + 1, 14).Resize(UBound(ar2, 1)) = Application.Transpose(ar2)
    End If
    
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Try this on a copy of your data. It will clear all other columns except A and N. Change the sheet name to suit.

VBA Code:
Option Explicit
Sub GeorgeTimes()
    Dim ar, ar2, ar3, i As Long, n As Long, ws As Worksheet
    Set ws = Worksheets("Sheet1")   '<<< change to suit actual sheet name
    Application.ScreenUpdating = False
   
    'Store the blank Acc. nos in an array
    ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlYes
    Dim LRow1 As Long, LRow2 As Long
    LRow1 = ws.Cells(Rows.Count, 1).End(3).Row + 1
    LRow2 = ws.Cells(Rows.Count, 14).End(3).Row
    ar2 = ws.Range(ws.Cells(LRow1, 14), ws.Cells(LRow2, 14)).Value
   
    'Delete blank Acc. no rows
    ws.Range("A2", ws.Cells(LRow1, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
   
    'Consolidate duplicates
    ar = Sheet1.Range("A1").CurrentRegion.Offset(1)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(ar, 1)
            .Item(ar(i, 1)) = .Item(ar(i, 1)) + ar(i, 14)
        Next
        ar = Array(.keys)
        ar3 = Array(.items)
        n = .Count
    End With
   
    'Put values back to sheet
    ws.Range("A1").CurrentRegion.Offset(1).ClearContents
    ws.Range("A2").Resize(n, 1).Value = Application.Transpose(ar)
    ws.Range("N2").Resize(n, 1).Value = Application.Transpose(ar3)
   
    If LRow1 = LRow2 Then
        ws.Cells(n + 1, 14) = ar2
    Else
        ws.Cells(n + 1, 14).Resize(UBound(ar2, 1)) = Application.Transpose(ar2)
    End If
   
    Application.ScreenUpdating = True
End Sub

Thank Kevin, that works.

Can you help me modify your macro in order to keep the rest of the columns as well?
 
Upvote 0
Here's an alternative (probably simpler). This will be my last post for the night :)

VBA Code:
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
 
Upvote 0
Solution

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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