Solved: Summarise Duplicate Help

[jacksonworld]

Hi all,

I recently obtained some code to summarise duplicate values in a range, whereby in a 2 column 2 row range, if the values in the first column where the same, the values in the second column would be added. (Incidentally, I have forgotten the author of this helpful code. My apologies to whoever you may be.)

Anyhow, I was hoping someone could please assist in altering this code for me.

First of all, rather than add all of the columns except column one, I was hoping to summarise only columns 5-7.

And secondly, I was hoping to also check for duplicates in column 4. So if duplicates existing in the first column, the macro must then check column 4 for duplicates before summarising.

I realise this may not make as much sense as I would like, so I have attached a simple example spreadsheet.

Here is the code that I have at the moment. I would very grateful if someone can help.

Thank you

[VBA]Sub SummariseDuplicates()
Dim cel As Range, rg1 As Range, rg2 As Range
Dim ckValue As String, i As Long, j As Long
Dim wb1 As Workbook, ws1 As Worksheet
Dim vcels As Variant, ditem As Variant, vHeader As Variant

Dim DuplicatesDic As Object
Set DuplicatesDic = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set ws1 = ActiveSheet
Set rg1 = Intersect(Selection.Columns(1).EntireColumn, ws1.UsedRange).Offset(1)
vHeader = Intersect(ws1.Rows(1).EntireRow, ws1.UsedRange).Value
For Each cel In rg1
ckValue = LCase(cel)
If ckValue <> "" Then
Set rg2 = Intersect(cel.EntireRow, ws1.UsedRange)
If Not DuplicatesDic.exists(ckValue) Then
vcels = rg2
DuplicatesDic.Add ckValue, vcels
Else
vcels = DuplicatesDic(ckValue)
For i = LBound(vcels, 2) To UBound(vcels, 2)
If IsNumeric(vcels(1, i)) And IsNumeric(rg2.Cells(i)) And i <> cel.Column Then
vcels(1, i) = vcels(1, i) + rg2.Cells(i)
End If
Next i
DuplicatesDic.Remove ckValue
DuplicatesDic.Add ckValue, vcels
End If
End If
Next cel
ws1.Cells.Clear
ws1.Range(Cells(1, 1), Cells(1, UBound(vHeader, 2))) = vHeader
i = 1
For Each ditem In DuplicatesDic.Items
i = i + 1
ws1.Range(Cells(i, 1), Cells(i, UBound(ditem, 2))) = ditem
Next ditem
Application.ScreenUpdating = True

Set DuplicatesDic = Nothing
End Sub[/VBA]

[Shazam]

Sorry I over posted.

[Shazam]

I was thinking over and I think it could be done with a simple SUMIF function.

Input formula in cell E10 copy down and across.

=SUMIF($D$1:$D$3,$D10,E$1:E$3)

[jacksonworld]

Thanks Shazam. Your answer has made me realise that I am an idiot in that I forgot to post my original code that requires changes. I apologise.

[VBA]Sub SummariseDuplicates()
Dim cel As Range, rg1 As Range, rg2 As Range
Dim ckValue As String, i As Long, j As Long
Dim wb1 As Workbook, ws1 As Worksheet
Dim vcels As Variant, ditem As Variant, vHeader As Variant

Dim DuplicatesDic As Object
Set DuplicatesDic = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False
Set wb1 = ActiveWorkbook
Set ws1 = ActiveSheet
Set rg1 = Intersect(Selection.Columns(1).EntireColumn, ws1.UsedRange).Offset(1)
vHeader = Intersect(ws1.Rows(1).EntireRow, ws1.UsedRange).Value
For Each cel In rg1
ckValue = LCase(cel)
If ckValue <> "" Then
Set rg2 = Intersect(cel.EntireRow, ws1.UsedRange)
If Not DuplicatesDic.exists(ckValue) Then
vcels = rg2
DuplicatesDic.Add ckValue, vcels
Else
vcels = DuplicatesDic(ckValue)
For i = LBound(vcels, 2) To UBound(vcels, 2)
If IsNumeric(vcels(1, i)) And IsNumeric(rg2.Cells(i)) And i <> cel.Column Then
vcels(1, i) = vcels(1, i) + rg2.Cells(i)
End If
Next i
DuplicatesDic.Remove ckValue
DuplicatesDic.Add ckValue, vcels
End If
End If
Next cel
ws1.Cells.Clear
ws1.Range(Cells(1, 1), Cells(1, UBound(vHeader, 2))) = vHeader
i = 1
For Each ditem In DuplicatesDic.Items
i = i + 1
ws1.Range(Cells(i, 1), Cells(i, UBound(ditem, 2))) = ditem
Next ditem
Application.ScreenUpdating = True

Set DuplicatesDic = Nothing
End Sub[/VBA]

[jindon]

For me it is not clear which column to be matched
assuming Col.A to be matched..
[vba]
Sub test()
Dim a, i As Long, ii As Integer, w(), y
With ActiveSheet.UsedRange
a = .Value
.Clear
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 2 To UBound(a, 1)
If Not IsEmpty(a(i, 1)) Then
If Not .Exists(a(i, 1)) Then
Redim w(1 To UBound(a, 2))
For ii = 2 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Add a(i, 1), w
Else
w = .item(a(i, 1))
For ii = 2 To UBound(a, 2)
If IsNumeric(a(i, ii)) Then w(ii) = w(ii) + a(i, ii)
Next
.item(a(i, 1)) = w
End If
End If
Next
y = .Items : Erase a
End With
With ActiveSheet.Range("a1")
For i = 0 To UBound(y)
.Offset(i).Resize(,UBound(y(i))) = y(i)
Next
End With
Erase y
End Sub
[/vba]

[jacksonworld]

Thanks Jidon. Column A is the first column to check for duplicates. However, unfortunately the code you supplied did not work. Any ideas?

[lucas]

Would probably help jindon if you stated what did not work about it.....did you get an error, if so what was the error. Did it not perform on the column you wanted it to, etc.

[jacksonworld]

Good point. Thanks.

I tried the code on the simple example I attached. It deleted the duplicates altogether and changed the figures in the non-dupicate row.

Sorry if I am not explaining myself clearly. I am doing my best.

[jindon]

OK
This is to summarize col.5-7(add) for unique iD col.A + col.D
[vba]
Sub test()
Dim a, i As Long, ii As Integer, w(), y, z As String
With ActiveSheet.UsedRange
a = .Value
.Clear
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 2 To UBound(a, 1)
z = a(i, 1) & ";" & a(i, 4)
If Len(z) >1 Then
If Not .Exists(z) Then
Redim w(1 To UBound(a, 2))
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Add z, w
Else
w = .item(z)
For ii = 5 To 7
w(ii) = w(ii) + a(i, ii)
Next
.item(z) = w
End If
End If
Next
y = .Items : Erase a
End With
With ActiveSheet.Range("a1")
For i = 0 To UBound(y)
.Offset(i).Resize(,UBound(y(i))) = y(i)
Next
End With
Erase y
End Sub
[/vba]

[jacksonworld]

Thanks for your persistence Jindon. I really do appreciate it.

There is a minor error in the code, which I have unsuccessfully tried to fix.

[VBA]z = a(i, 1) & ";" a(i, 4)[/VBA]

How do I fix it?

Thanks

[johnske]

Thanks for your persistence Jindon. I really do appreciate it.

There is a minor error in the code, which I have unsuccessfully tried to fix.

[vba]z = a(i, 1) & ";" a(i, 4)[/vba]

How do I fix it?

Thanks

[vba]z = a(i, 1) & ";" & a(i, 4)[/vba]

[jindon]

Thanks for your persistence Jindon. I really do appreciate it.

There is a minor error in the code, which I have unsuccessfully tried to fix.

[vba]z = a(i, 1) & ";" a(i, 4)[/vba]

How do I fix it?

Thanks

Sorry should be

z=a(i, 1) & ";" & a(i, 4)

[jacksonworld]

Thanks guys.

I am receiving the Run-time error mesage "This key is associated with an element of this collection" for the following part of the code.

[VBA].Add a(i, 1), w [/VBA]

Sorry if this is taking a while.

[jindon]

Sorry again..

should be

 .add z, w

and

.item(z) = w

Previous code has been modified, so copy entire code again and test it..

[jacksonworld]

Okey dokey. The duplicate is successfully being deleted, but unsuccessfully being summarised.

The duplicates are correctly being condensed to one entry, however Columns E-G are not being summed for each column.

The battle continues.

[jindon]

Okey dokey. The duplicate is successfully being deleted, but unsuccessfully being summarised.

The duplicates are correctly being condensed to one entry, however Columns E-G are not being summed for each column.

The battle continues.

No idea,,
Are they numbers?

[jacksonworld]

Yeah, they are numbers. I am testing it on the example spreadsheet I attached at the beginning. I have attached it again.

After the macro, the result should be the "answer" on Sheet 1.

Thanks again.

[jindon]

Unfortunately, I am currently unable to use excel with my PC,
so I can not even test the code at the moment....
If the code is running without error, it may be something to do with the cell format, not sure though
try
[vba]
Sub test()
Dim a, i As Long, ii As Integer, w(), y, z As String
With ActiveSheet.UsedRange
a = .Value
.Clear
End With
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 2 To UBound(a, 1)
z = a(i, 1) & ";" & a(i, 4)
If Len(z) >1 Then
If Not .Exists(z) Then
Redim w(1 To UBound(a, 2))
For ii = 1 To UBound(a, 2)
w(ii) = a(i, ii)
Next
.Add z, w
Else
w = .item(z)
For ii = 5 To 7
w(ii) = Val(w(ii)) + Val(a(i, ii))
Next
.item(z) = w
End If
End If
Next
y = .Items : Erase a
End With
With ActiveSheet.Range("a1")
For i = 0 To UBound(y)
.Offset(i).Resize(,UBound(y(i))) = y(i)
Next
End With
Erase y
End Sub
[/vba]

[jacksonworld]

I'm impressed you are doing this without Excel.

However, I am receiving the same result. I checked the cell format, but it is set to General.

Puzzling.

[jindon]

OK

Can you do the step debugging for me?

1) Open vb editor and go to [View]-[LocaWindow]
2) Click somewhere on the code then hit F8
3) As you hit F8, the code execute line by line and you will see all the variables in LocalWindow
4) if you come to the line of For ii = 5 To 7, Pleas watch into variable w
which will be with + sign and if you click on the sign, you will see the progress as you hit F8
5) Please check if the values w(5) to w(7) is changing or not

rgds