# Counting Duplicates in a list according to dates and numbers

#### monmon

##### Board Regular
Hi all, I've the following that I couldn't solve. Please try to help.

I've a list of raw data on the left (Columns A, B & C).

The desired results I need is on the right (Columns E, F, G, H).

I need a macro that enables me to group them in accordance to their Dates and No. and in column H to count the number of times the combination appears.

 Names Dates No. Desired results Tom 12/12/2011 1 Name Dates No. Count Tom 12/12/2011 1 Tom 12/12/2011 1 2 Tom 12/12/2011 2 Tom 12/12/2011 2 1 Tom 12/12/2011 3 Tom 12/12/2011 3 1 serene 12/12/2011 1 Serene 12/12/2011 1 2 serene 12/12/2011 1 Serene 12/13/2011 1 2 serene 12/13/2011 1 Tom 12/13/2011 2 2 serene 12/13/2011 1 Tom 12/13/2011 1 1 Tom 12/13/2011 2 Gill 12/13/2011 1 2 Tom 12/13/2011 2 Tom 12/13/2011 1 Gill 12/13/2011 1 Gill 12/13/2011 1

<tbody>
</tbody>

I've the following macro that allows me to ONLY groups and counts them in accordance to the dates. However, I need to include another criteria which is No.

 Sub MG26Dec46 Dim Rng As Range Dim Dn As Range Dim Twn As String Dim Q Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp)) With CreateObject("scripting.dictionary") .CompareMode = vbTextCompare For Each Dn In Rng Twn = Dn & Dn.Offset(, 1) If Not .Exists(Twn) Then .Add Twn, Array(Dn, Dn.Offset(, 1), 1) Else Q = .Item(Twn) Q(2) = Q(2) + 1 .Item(Twn) = Q End If Next Range("E3").Resize(.Count, 3) = Application.Transpose(Application.Transpose(.Items)) End With End Sub

<colgroup><col width="64" style="width: 48pt;"></colgroup><tbody>
</tbody>

Can anyone help to modify the macro such that it will include the No. and produce the results as in the table above?

### Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

#### MickG

##### MrExcel MVP
Try this:-
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG01Apr01
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Twn     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Dim[/COLOR] c       [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 4)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Twn = Dn & Dn.Offset(, 1) & Dn.Offset(, 2)
[COLOR="Navy"]If[/COLOR] Not .Exists(Twn) [COLOR="Navy"]Then[/COLOR]
ray(1, 1) = Dn(, 1)
ray(1, 2) = Dn(, 2)
ray(1, 3) = Dn(, 3)
ray(1, 4) = 1
[COLOR="Navy"]Else[/COLOR]
Q = .Item(Twn)
Q(0)(Q(1), 4) = Q(0)(Q(1), 4) + 1
.Item(Twn) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
c = c + 1
[COLOR="Navy"]For[/COLOR] Ac = 1 To 4
Cells(c, Ac + 4) = .Item(K)(0)(1, Ac)
[COLOR="Navy"]Next[/COLOR] Ac
[COLOR="Navy"]Next[/COLOR] K
Range("H1") = "Count"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

#### cbuchman

##### New Member
Also try using a pivot table.

#### monmon

##### Board Regular
Try this:-
Code:
``````[COLOR=navy]Sub[/COLOR] MG01Apr01
[COLOR=navy]Dim[/COLOR] Rng     [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Dn      [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Twn     [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] Q
[COLOR=navy]Dim[/COLOR] c       [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To Rng.Count, 1 To 4)
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
Twn = Dn & Dn.Offset(, 1) & Dn.Offset(, 2)
[COLOR=navy]If[/COLOR] Not .Exists(Twn) [COLOR=navy]Then[/COLOR]
ray(1, 1) = Dn(, 1)
ray(1, 2) = Dn(, 2)
ray(1, 3) = Dn(, 3)
ray(1, 4) = 1
[COLOR=navy]Else[/COLOR]
Q = .Item(Twn)
Q(0)(Q(1), 4) = Q(0)(Q(1), 4) + 1
.Item(Twn) = Q
[COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] K
[COLOR=navy]Dim[/COLOR] Ac [COLOR=navy]As[/COLOR] [COLOR=navy]Integer[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
c = c + 1
[COLOR=navy]For[/COLOR] Ac = 1 To 4
Cells(c, Ac + 4) = .Item(K)(0)(1, Ac)
[COLOR=navy]Next[/COLOR] Ac
[COLOR=navy]Next[/COLOR] K
Range("H1") = "Count"
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]``````
Regards Mick

Hi Mick, this is Great! This is absolutely great! Thank you!

I'm a newbie in this, so let's say if the criteria changes to the following, how should I alter in order to keep including new criteria?
 Name date No. hotel Tom 12/12/2011 1 fair

<TBODY>
</TBODY>

#### MickG

##### MrExcel MVP
Try this:-
NB:- Its a slightly more refined version !!!
Should work unless you have 1000,s of rows.
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG02Apr53
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Twn     [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim ray(1 To 5)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Twn = Dn & Dn.Offset(, 1) & Dn.Offset(, 2) & Dn.Offset(, 3)
[COLOR="Navy"]If[/COLOR] Not .Exists(Twn) [COLOR="Navy"]Then[/COLOR]
ray(1) = Dn(, 1)
ray(2) = Dn(, 2)
ray(3) = Dn(, 3)
ray(4) = Dn(, 4)
ray(5) = 1
[COLOR="Navy"]Else[/COLOR]
Q = .Item(Twn)
Q(5) = Q(5) + 1
.Item(Twn) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Range("E1").Resize(.Count, 5) = Application.Transpose(Application.Transpose(.items))
Range("I1") = "Count"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

Replies
4
Views
249
Replies
1
Views
187
Replies
5
Views
296
Replies
3
Views
184
Replies
3
Views
213

1,195,936
Messages
6,012,393
Members
441,695
Latest member
MickRobertson

### 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.

### Which adblocker are you using?

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

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