Macro to count occurances of decimal value

[Excelnewbie001]

Looking for a macro that can count the occurrences of the decimal values in column O2-O20 and count and write them from highest to lowest in Q2-Q

20 .Any help much appreciated

https://files.fm/u/6k5ug2cq#/view/Count.jpg

P.S Your upload picture dont work on this website

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG16Feb40
[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] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Rng = Range("O2", Range("O" & Rows.Count).End(xlUp))
[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 Int(Dn.Value) = Dn.Value [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(CStr(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
             Dic.Add CStr(Dn.Value), 1
        [COLOR="Navy"]Else[/COLOR]
            Dic(CStr(Dn.Value)) = Dic(CStr(Dn.Value)) + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Lg [COLOR="Navy"]As[/COLOR] Double, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]With[/COLOR] Range("Q2").Resize(Dic.Count)
    .Value = Application.Transpose(Dic.keys())
    .Sort Range("Q2"), xlDescending
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Range("Q2").Resize(Dic.Count)
  [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    [COLOR="Navy"]If[/COLOR] Val(K) = Dn.Value [COLOR="Navy"]Then[/COLOR]
        Dn.Value = Dn.Value & "(" & Dic(CStr(K)) & ")"
     [COLOR="Navy"]End[/COLOR] If
   [COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]Next[/COLOR] Dn

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

Regards Mick

 

[Excelnewbie001]

Hi Mick

Thank you very much for your macro. It works but is there any way the results can only be one decimal place.Currently it looks like this

3.66666666666667(1)

2.33333333333333(3)

1.66666666666667(1)

0.666666666666667(1)

0.333333333333333(1)

<colgroup><col></colgroup><tbody>
</tbody>

Can it look like this

3.7
2.3
1.7
0.7
0.3

The counting works perfectly -very well done Sir some great coding. Thanks for your help

Try this:-

[COLOR=Navy]Sub[/COLOR] MG16Feb40
[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] Q [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Set[/COLOR] Rng = Range("O2", Range("O" & Rows.Count).End(xlUp))
[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 Int(Dn.Value) = Dn.Value [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(CStr(Dn.Value)) [COLOR=Navy]Then[/COLOR]
             Dic.Add CStr(Dn.Value), 1
        [COLOR=Navy]Else[/COLOR]
            Dic(CStr(Dn.Value)) = Dic(CStr(Dn.Value)) + 1
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]Dim[/COLOR] K [COLOR=Navy]As[/COLOR] Variant, Lg [COLOR=Navy]As[/COLOR] Double, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]

[COLOR=Navy]With[/COLOR] Range("Q2").Resize(Dic.Count)
    .Value = Application.Transpose(Dic.keys())
    .Sort Range("Q2"), xlDescending
[COLOR=Navy]End[/COLOR] With

[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Range("Q2").Resize(Dic.Count)
  [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] Dic.keys
    [COLOR=Navy]If[/COLOR] Val(K) = Dn.Value [COLOR=Navy]Then[/COLOR]
        Dn.Value = Dn.Value & "(" & Dic(CStr(K)) & ")"
     [COLOR=Navy]End[/COLOR] If
   [COLOR=Navy]Next[/COLOR] K
[COLOR=Navy]Next[/COLOR] Dn

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

Regards Mick

 

[MickG]

I Imagine its because your basic data has multiple decimal places and has been formatted down to 2 numbers.
Try changing the line as shown below in Red:-

Dn.Value =[COLOR="#FF0000"][B] Format(Dn.Value, "0.0") [/B][/COLOR]& "(" & Dic(CStr(K)) & ")"

 

[Excelnewbie001]

I Imagine its because your basic data has multiple decimal places and has been formatted down to 2 numbers.
Try changing the line as shown below in Red:-

Dn.Value =[COLOR=#FF0000][B] Format(Dn.Value, "0.0") [/B][/COLOR]& "(" & Dic(CStr(K)) & ")"

Fabulous that sorted it out -Thank you for solving it -Great coding and Skills -Much respect you are truly a great MVP Thanks again

Excelnewbie001

 

[MickG]

You're welcome

 

[Excelnewbie001]

You're welcome

MickG dont know if I must open a new question as it pertain to above macro -is it any ways possible to sort the counts from Highest to lowest in Column Q -if thats possible it will be great

Example

1.7(7)
4.0(4)
0.3(1)

So the highest counts at the top and the lowest at the bottom


If you can please advise if I should open a new question
Thanks again for your help

Excelnewbie

 

[MickG]

Try this for results starting "Q2" .
NB:- The code uses column "R" as a helper column.

[COLOR="Navy"]Sub[/COLOR] MG18Feb10
[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] Q [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Set[/COLOR] Rng = Range("O2", Range("O" & Rows.Count).End(xlUp))
[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 Int(Dn.Value) = Dn.Value [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(CStr(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
             Dic.Add CStr(Dn.Value), 1
        [COLOR="Navy"]Else[/COLOR]
            Dic(CStr(Dn.Value)) = Dic(CStr(Dn.Value)) + 1
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]With[/COLOR] Range("q2").Resize(Dic.Count, 2)
    .Value = Application.Transpose(Array(Dic.keys, Dic.items))
    .Sort Range("R2"), xlDescending
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Range("q2").Resize(Dic.Count)
    Dn = Format(Dn.Value, "0.0") & "(" & Dn.Offset(, 1).Value & ")"
    Dn.Offset(, 1).Value = ""
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Excelnewbie001]

Hi Mick

Thank you very much for the ammendmend it works great -Fantastic coding and thanks again for your help -MUCH appreciated

Try this for results starting "Q2" .
NB:- The code uses column "R" as a helper column.

[COLOR=Navy]Sub[/COLOR] MG18Feb10
[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] Q [COLOR=Navy]As[/COLOR] Variant
[COLOR=Navy]Dim[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]Set[/COLOR] Rng = Range("O2", Range("O" & Rows.Count).End(xlUp))
[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 Int(Dn.Value) = Dn.Value [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]If[/COLOR] Not Dic.Exists(CStr(Dn.Value)) [COLOR=Navy]Then[/COLOR]
             Dic.Add CStr(Dn.Value), 1
        [COLOR=Navy]Else[/COLOR]
            Dic(CStr(Dn.Value)) = Dic(CStr(Dn.Value)) + 1
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]

[COLOR=Navy]With[/COLOR] Range("q2").Resize(Dic.Count, 2)
    .Value = Application.Transpose(Array(Dic.keys, Dic.items))
    .Sort Range("R2"), xlDescending
[COLOR=Navy]End[/COLOR] With

[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Range("q2").Resize(Dic.Count)
    Dn = Format(Dn.Value, "0.0") & "(" & Dn.Offset(, 1).Value & ")"
    Dn.Offset(, 1).Value = ""
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

 

[MickG]

You're welcome