highlighting top10% and bottom 10% from a row of numbers

[Subu]

Hi

I have product by customer (product x customer) spread sheet where I need to identify the top 10% items and bottom 10% items (by values) and give them some colour. A sample array is given below in line on this query. A sample spread sheet with the same data is uploaded to bit.ly/1Ts5AZk

The actual spread sheet has 1000s of lines and so a VBA is kindly requested to shade the top and bottom 10%s

I'm using Excel 2010 on a win 2000 machine. I have tried to search Mr Excel, but couldn't find a proper VBA... so even pointers to the right thread would be most appreciated. Any help would be most appreciated.

Sample :

Product	customer	Kilos	$ / KG	comments	comments
product 1	customer 1	10 KG	2.00	=> bottom 10% (out of 10 cases) in av. sale price	=> say colour red
product 1	customer 2	20 KG	2.10		No colour
product 1	customer 3	30 KG	2.70		No colour
product 1	customer 4	50 KG	3.10		No colour
product 1	customer 5	60 KG	4.00		No colour
product 1	customer 6	60 KG	2.50		No colour
product 1	customer 7	70 KG	8.00	=> top 10% (out of 10 cases) in Av. Sale price	=> colour Green
product 1	customer 8	80 KG	8.00	- do -	=> colour Green
product 1	customer 9	90 KG	3.00		No colour
product 1	customer 10	100 KG	5.00		No colour
product 2	customer 1	100KG	13.10		No colour
product 2	customer 2	200KG	12.10		No colour
product 2	customer 3	300KG	12.70		No colour
product 2	customer 4	500KG	12.00	=> bottom 10% (out of 10 cases) in av. sale price	=> colour red
product 2	customer 5	600KG	14.00		No colour
product 2	customer 6	600KG	12.50		No colour
product 2	customer 7	705KG	18.00	=> top 10% (out of 10 cases) in Av. Sale price	=> colour Green
product 2	customer 8	801KG	18.00	- do -	=> colour Green
product 2	customer 9	904KG	13.00		No colour
product 2	customer 10	185KG	15.00		No colour

<tbody>
</tbody>

...and so on ....

Thanks and regards

Subu

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG18Feb11
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Pc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer,[/COLOR] Lg [COLOR="Navy"]As[/COLOR] Double, Sm [COLOR="Navy"]As[/COLOR] Double, R [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    Pc = Dn.Count * 0.1
    Lg = Application.Large(Dn.Offset(, 3).Value, Pc)
    Sm = Application.Small(Dn.Offset(, 3), Pc)
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
            [COLOR="Navy"]If[/COLOR] R.Offset(, 3) = Sm [COLOR="Navy"]Then[/COLOR] R.Offset(, 3).Interior.Color = vbRed
            [COLOR="Navy"]If[/COLOR] R.Offset(, 3) = Lg [COLOR="Navy"]Then[/COLOR] R.Offset(, 3).Interior.Color = vbGreen
        [COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Subu]

Boss Mick G you are awesome !

Your VBA works like a charm on the original sample

My bad, I made a mistake on the first / original sample ... the sample has blank lines between each product, the real one does not have blank lines / breaks between products

Now, I tried the VBA as is on the sheet without line breaks, of course the "range" is not expected to work, and does not work

So could you pl modify your VBA for a situation / sp sheet where everything is the same as the first sp sheet, except that there are NO blank lines between products

Another sample is enclosed at bit.ly/1KujZBF

This sample is VBA enabled XL with your VBA in it

PS : Yes, some addl columns & rows can be found on this sample, those rows / columns I assume this can be handled by changing the start of range from A3 to K6 or whatever, However IF that thinking is flawed please correct that as well !!



thanks again
best regards
subu

 

[MickG]

Try this:-
NB:- The 10% margin was calculated by Taking the min Sale price from Max sale price for each product, then finding the 10% and then
Adding/ subtracting fro Max/ min Value.
If not correct please advise !!!!!

[COLOR="Navy"]Sub[/COLOR] MG19Feb20
[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] Dic [COLOR="Navy"]As[/COLOR] Object, K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Double, Sm [COLOR="Navy"]As[/COLOR] Double, Lg [COLOR="Navy"]As[/COLOR] Double, G [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C6"), Range("C" & 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 Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, Array(Dn, Dn.Offset(, 8).Value, Dn.Offset(, 8).Value)
    [COLOR="Navy"]Else[/COLOR]
        Q = Dic(Dn.Value)
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, 8).Value < Q(1) [COLOR="Navy"]Then[/COLOR] Q(1) = Dn.Offset(, 8).Value
        [COLOR="Navy"]If[/COLOR] Dn.Offset(, 8).Value > Q(2) [COLOR="Navy"]Then[/COLOR] Q(2) = Dn.Offset(, 8).Value
        [COLOR="Navy"]Set[/COLOR] Q(0) = Union(Q(0), Dn)
        Dic(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    R = Dic(K)(2) - Dic(K)(1)
    Sm = 0.1 * R + Dic(K)(1)
    Lg = Dic(K)(2) - 0.1 * R
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic(K)(0)
            [COLOR="Navy"]If[/COLOR] G.Offset(, 8).Value <= Sm [COLOR="Navy"]Then[/COLOR] G.Offset(, 8).Interior.Color = vbRed
            [COLOR="Navy"]If[/COLOR] G.Offset(, 8).Value >= Lg [COLOR="Navy"]Then[/COLOR] G.Offset(, 8).Interior.Color = vbGreen
        [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] K
MsgBox "Run"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Subu]

You are a Genius ! This one works like a charm and yes you got the logic right !!

thanks a TON Mick

Really appreciate you taking time & effort to solve this

Best regards
Subu

 

[MickG]

You're very welcome