Excelnewbie001
Board Regular
- Joined
- Jan 25, 2017
- Messages
- 79
https://files.fm/u/6k5ug2cq#/view/Count.jpg
P.S Your upload picture dont work on this website
Last edited:
[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]
Try this:-
Regards MickCode:[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]
Dn.Value =[COLOR="#FF0000"][B] Format(Dn.Value, "0.0") [/B][/COLOR]& "(" & Dic(CStr(K)) & ")"
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:-
Code:Dn.Value =[COLOR=#FF0000][B] Format(Dn.Value, "0.0") [/B][/COLOR]& "(" & Dic(CStr(K)) & ")"
You're welcome
[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]
Try this for results starting "Q2" .
NB:- The code uses column "R" as a helper column.
Regards MickCode:[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]