PDA

View Full Version : Solved: Summarise Duplicate Help



jacksonworld
06-29-2006, 06:16 PM
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

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

Shazam
06-29-2006, 06:49 PM
Sorry I over posted.

Shazam
06-29-2006, 06:57 PM
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
06-29-2006, 07:31 PM
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.

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

jindon
06-30-2006, 11:20 PM
For me it is not clear which column to be matched
assuming Col.A to be matched..

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

jacksonworld
07-02-2006, 06:50 PM
Thanks Jidon. Column A is the first column to check for duplicates. However, unfortunately the code you supplied did not work. Any ideas?

lucas
07-02-2006, 07:02 PM
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
07-02-2006, 07:17 PM
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
07-03-2006, 05:52 PM
OK
This is to summarize col.5-7(add) for unique iD col.A + col.D

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

jacksonworld
07-03-2006, 06:48 PM
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.

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

How do I fix it?

Thanks

johnske
07-03-2006, 07:01 PM
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.

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

How do I fix it?

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

jindon
07-03-2006, 07:04 PM
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.

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

How do I fix it?

Thanks

Sorry should be


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

jacksonworld
07-03-2006, 08:31 PM
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.

.Add a(i, 1), w

Sorry if this is taking a while.

jindon
07-03-2006, 08:41 PM
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
07-03-2006, 10:39 PM
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
07-03-2006, 10:51 PM
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
07-04-2006, 04:13 PM
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
07-04-2006, 05:35 PM
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

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

jacksonworld
07-04-2006, 06:46 PM
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
07-04-2006, 06:58 PM
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

jacksonworld
07-04-2006, 09:10 PM
OK, I have followed your instructions.

The line ii=5 to 7 is never actually highlighted. :think:

jindon
07-04-2006, 10:08 PM
Hummmm

That means, there is no dups...

strange..

Would you mind to show me a few data in Col.A and Col.D to be compared?

jacksonworld
07-04-2006, 11:02 PM
Strange indeed.

Here is the example I am testing it on.

duplicate (blank) (blank) (blank) fox 1 5 5
duplicate (blank) (blank) (blank) cat 2 6 7
duplicate (blank) (blank) (blank) fox 3 4 8


So it should result in:

duplicate (blank) (blank) (blank) fox 4 9 13
duplicate (blank) (blank) (blank) cat 2 6 7


But I am receiving:

duplicate (blank) (blank) (blank) cat 2 6 7
duplicate (blank) (blank) (blank) fox 3 4 8

jindon
07-04-2006, 11:37 PM
Ok
I want to make sure that what I'm tryign to do with my code..

1) put the data (UsedRange) to an array vaiable "a"
2) Looping though array from row2, my guess is you have header on row1
and the UsedRange start from A1
3) checking duplicates for Col.A & Col.D string
4) if any duplicates, col.E to G will be aggregated.

Is this what you wanted?

jacksonworld
07-05-2006, 06:33 PM
Thanks Jindon.

That seems right to me. Although, I am no longer using row 1 as a header, so you can scrap that.

Thanks again.

jindon
07-05-2006, 06:48 PM
Thanks Jindon.

That seems right to me. Although, I am no longer using row 1 as a header, so you can scrap that.

Thanks again.

If you don't have header then change


For i = 2 To UBound(a, 1)
To


For i = 1 To UBound(a, 1)

jacksonworld
07-05-2006, 06:58 PM
OK. So say I wanted to perform this on rows 5 onwards, would I change the code to For i = 5 To UBound(a, 1) ?

jindon
07-05-2006, 07:05 PM
Just 1 is fine, because the code ignores the rows that has col.A and Col.D are both blank.

jacksonworld
07-05-2006, 07:15 PM
It works! :thumb

Thank you so much, Jindon. I really appreciate your help.

If you are ever running for election somewhere, I will help you with your campaign. :bow: