Find Unique Entries in a Column and Count how many times they occur

[zaincmt]

Hi All,

I am trying to create a VBA script to look through an automatic generated report on one of the tabs called "All". What I need it to do is look through Column "A" and find the unique Entries and how many times these unique entries appear. Then put the results in a new tab called "Summary".

[table="width: 500, class: grid, align: center"]
[tr]
[td]GpBr[/td]
[td]#[/td]
[/tr]
[tr]
[td]U111[/td]
[td]1234[/td]
[/tr]
[tr]
[td]U111[/td]
[td]1235[/td]
[/tr]
[tr]
[td]U112[/td]
[td]1236[/td]
[/tr]
[tr]
[td]U112[/td]
[td]1237[/td]
[/tr]
[tr]
[td]U113[/td]
[td]1238[/td]
[/tr]
[tr]
[td]U114[/td]
[td]1239[/td]
[/tr]
[/table]

So once I have run the script it will create a new summary tab with the following.

[table="width: 500, class: grid, align: center"]
[tr]
[td]Unique Entries[/td]
[td]Occurences[/td]
[/tr]
[tr]
[td]U111[/td]
[td]2[/td]
[/tr]
[tr]
[td]U112[/td]
[td]2[/td]
[/tr]
[tr]
[td]U113[/td]
[td]1[/td]
[/tr]
[tr]
[td]U114[/td]
[td]1[/td]
[/tr]
[/table]


I did manage to find some code but I cant get it to work how I need to by creating a new "Summary" tab etc.

Sub Special_Countif()
 Dim i, LastRowA, LastRowB
 LastRowA = Range("A" & Rows.Count).End(xlUp).Row
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Columns("B:C").ClearContents
 For i = 1 To LastRowA
 If Application.CountIf(Range("B:B"), Cells(i, "A")) = 0 Then
 Cells(i, "B").Offset(1, 0).Value = Cells(i, "A").Value
 End If
 Next
 Columns("B:B").Select
 Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, _
 OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
 DataOption1:=xlSortNormal
 LastRowB = Range("B" & Rows.Count).End(xlUp).Row
 For i = 2 To LastRowB
 Cells(i, "C").Value = Application.CountIf(Range("A:A"), Cells(i, "B"))
 Next i
 Range("B1").Value = "Unique Entries"
 Range("C1").Value = "Occurrences"
 Range("B1:C1").HorizontalAlignment = xlCenter
 Range("B1").Select
 Columns("B:C").AutoFit
 Application.EnableEvents = True
 End Sub

Thank you for your help
GS!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG03Nov01
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]With[/COLOR] Sheets("All")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, 1
    [COLOR="Navy"]Else[/COLOR]
        Dic(Dn.Value) = Dic(Dn.Value) + 1
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Summary"
[COLOR="Navy"]With[/COLOR] ActiveSheet
    .Range("A2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
    .Range("A1:B1").Value = Array("Unique Entries", "Occurences")
        [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(Dic.Count + 1, 2)
            .Columns.AutoFit
            .Borders.Weight = 2
        [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] With


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[zaincmt]

Hi mick,

Sorry it was my fault. I added it into another piece of code which was causing the issue. I ran it on its own and it works very nicely. Thank you again.

Much Bromance!
Regards
GS

Hi Mick,

Thank you for that. Works almost perfectly. I just ran the code but its adding 2 onto the unique counter for each unique entry. So where it has 5 Occurrences of U111 in the data, on the summary tab its showing 7?

Is there a way to fix that?

Thank you for your help on this.
GS

 

[MickG]

I can't replicate your problem
Try Adding a test formula like :-=COUNTIF(A2:A30,A2)
And compare The code and the function output.

 

[zaincmt]

Hi Again,

This code would be quite handy for another report I need to create actually. I need to use the EXACT same code to count the unique entries in Column A then put it in a Summary tab. But is there anyway of including an IF statement to check if column "J" says "Other" then to select all the Unique Entries that in Column "A" that also have the word "Other" in Column "J" and copy to the Summary tab?

Thank you again for your help.

Hi mick,

Sorry it was my fault. I added it into another piece of code which was causing the issue. I ran it on its own and it works very nicely. Thank you again.

Much Bromance!
Regards
GS


Hi Mick,

Thank you for that. Works almost perfectly. I just ran the code but its adding 2 onto the unique counter for each unique entry. So where it has 5 Occurrences of U111 in the data, on the summary tab its showing 7?

Is there a way to fix that?

Thank you for your help on this.
GS

 

[MickG]

Try this:- for you latest Post:-

[COLOR="Navy"]Sub[/COLOR] MG03Nov23
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]With[/COLOR] Sheets("All")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
  [COLOR="Navy"]If[/COLOR] Dn.Offset(, 9).Value = "Other" [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, 1
    [COLOR="Navy"]Else[/COLOR]
        Dic(Dn.Value) = Dic(Dn.Value) + 1
    [COLOR="Navy"]End[/COLOR] If
  [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]


Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Summary"
[COLOR="Navy"]With[/COLOR] ActiveSheet
    .Range("A2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
    .Range("A1:B1").Value = Array("Unique Entries", "Occurences")
        [COLOR="Navy"]With[/COLOR] .Range("A1").Resize(Dic.Count + 1, 2)
            .Columns.AutoFit
            .Borders.Weight = 2
        [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[zaincmt]

Hey,

Thank you again for the response. Unfortunately I get an error: Run time error 13 - Type Mismatch on this line...

.Range("A2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
.Range("A1:B1").Value = Array("Unique Entries", "Occurences")

Any ideas? I have run it on its own with no other code. Thank you. Really appreciate it.

Regards
GS

 

[zaincmt]

No worries. I found the issue. It was because the "Other" is actually "OTher" in the columns. Sorry I didn't realize it was case sensitive.

This is absolutely fantastic. Thank you so much!! You saved me manually doing this every day for the next 3 months.

Have a fantastic day.

GS

 

[MickG]

You may need to change the last bit of code, its probably because the Dictionary.count = 0, because you have no values in "J" that = "Other"

If Dic.Count > 0 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Summary"
With ActiveSheet
    .Range("A2").Resize(Dic.Count, 2) = Application.Transpose(Array(Dic.Keys, Dic.items))
    .Range("A1:B1").Value = Array("Unique Entries", "Occurences")
        With .Range("A1").Resize(Dic.Count + 1, 2)
            .Columns.AutoFit
            .Borders.Weight = 2
        End With
End With
End If
End Sub