Counting Duplicates in a list according to dates and numbers

monmon

Board Regular
Joined
Apr 1, 2013
Messages
84
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.


NamesDatesNo.Desired results
Tom12/12/20111NameDatesNo.Count
Tom12/12/20111Tom12/12/201112
Tom12/12/20112Tom12/12/201121
Tom12/12/20113Tom12/12/201131
serene12/12/20111Serene12/12/201112
serene12/12/20111Serene12/13/201112
serene12/13/20111Tom12/13/201122
serene12/13/20111Tom12/13/201111
Tom12/13/20112Gill12/13/201112
Tom12/13/20112
Tom12/13/20111
Gill12/13/20111
Gill12/13/20111

<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?

Thanks in advance!!!!!
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
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
            .Add Twn, Array(ray, 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
 
Upvote 0
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
            .Add Twn, Array(ray, 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>
 
Upvote 0
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
            .Add Twn, ray
        [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
 
Upvote 0

Forum statistics

Threads
1,213,560
Messages
6,114,306
Members
448,564
Latest member
ED38

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