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

 

[kevin9999]

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?

 

[GeorgeTimes]

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
102099147	100.49
102099146	182.57

36.56

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

Account number	Amount
102105709	82.84
102099147	100.49
102099146	182.57

36.56

1 (second blank)

2 (thrid blank found)

I hope this makes sense.

 

[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

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

 

[kevin9999]

What's between columns A & N? Is there any chance you could provide a small sample of your data using the XL2BB add in?

 

[GeorgeTimes]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
1	Account number	TRX_NUMBER	TRX_DATE	DUE_DATE	BILL_ACTION	CREDITED_INV	Company number	PARTY_NAME	MANTLE_CODE	REFERENCE	PURCHASE_ORDER	CUSTOMER_REFERENCE	COMMENTS	AMOUNT_DUE_ORIGINAL	AMOUNT_DUE_REMAINING	DISPUTE_AMOUNT	PAYMENT_TERM	BILL_TO_ADDRESS1	BILL_TO_ADDRESS2	BILL_TO_ADDRESS3	BILL_TO_ADDRESS4	BILL_TO_CITY	BILL_TO_POSTAL_CODE	CATEGORY	CREATION_DATE	CREATED_BY	PRINT_STATUS	OU	COMPANY_NUM	SORT_COLUMN	CURRENCY_CODE	RU_NUMBER	RIMA_FLAG
2	102105709	6602849	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	22500225_1002_S	04/05/2017		Regular Bill	82.84	82.84		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:58	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86185094	GBP	31671904
3	102099148	6023067	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	9.6	PP- 09082019		Regular Bill	27.36	27.36		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177409	GBP	31671904
4	102099147	6023066	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	7.67	24- 09082019		Regular Bill	73.13	73.13		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177408	GBP	31671904
5	102099147	6023065	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	9.6	24- 09082019		Regular Bill	54.72	54.72		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177407	GBP	31671904
6	102099146	6023064	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	7.67	12072019		Regular Bill	73.13	73.13		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177406	GBP	31671904
7	102099146	6023063	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	9.6	12072019		Regular Bill	54.72	54.72		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177405	GBP	31671904
8	102099146	6023062	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	7.67	H- 29052019		Regular Bill	36.56	36.56		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177404	GBP	31671904
9		6023061	06-Sep-22	06-Oct-22	Invoice		1000349571	A	RG574	9.6	H- 29052019		Regular Bill	27.36	27.36		30D	c/o Data Capture Solutions	PO Box			SLOUGH	SL3 5XZ	OKS CONTRACTS	06/09/2022 22:49	BATCH_UK_BILLING	PRINTED	UK	1000349571	-86177403	GBP	31671904
Sheet2

 

[kevin9999]

Thanks for that George.

 

[kevin9999]

Try this on a copy of your data. It will clear all other columns except A and N. Change the sheet name to suit.

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

 

[GeorgeTimes]

Try this on a copy of your data. It will clear all other columns except A and N. Change the sheet name to suit.

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?

 

[kevin9999]

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