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

Subu

New Member
Joined
May 28, 2012
Messages
42
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 :

ProductcustomerKilos$ / KGcomments comments
product 1customer 110 KG2.00=> bottom 10% (out of 10 cases) in av. sale price=> say colour red
product 1customer 220 KG2.10No colour
product 1customer 330 KG2.70No colour
product 1customer 450 KG3.10No colour
product 1customer 560 KG4.00No colour
product 1customer 660 KG2.50No colour
product 1customer 770 KG8.00=> top 10% (out of 10 cases) in Av. Sale price=> colour Green
product 1customer 880 KG8.00 - do -=> colour Green
product 1customer 990 KG3.00No colour
product 1customer 10100 KG5.00No colour
product 2customer 1100KG13.10No colour
product 2customer 2200KG12.10No colour
product 2customer 3300KG12.70No colour
product 2customer 4500KG12.00=> bottom 10% (out of 10 cases) in av. sale price=> colour red
product 2customer 5600KG14.00No colour
product 2customer 6600KG12.50No colour
product 2customer 7705KG18.00=> top 10% (out of 10 cases) in Av. Sale price=> colour Green
product 2customer 8801KG18.00- do -=> colour Green
product 2customer 9904KG13.00No colour
product 2customer 10185KG15.00No colour

<tbody>
</tbody>

...and so on ....

Thanks and regards

Subu
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Try this:-
Code:
[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

New Member
Joined
May 28, 2012
Messages
42
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

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
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 !!!!!
Code:
[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

New Member
Joined
May 28, 2012
Messages
42
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
 

Watch MrExcel Video

Forum statistics

Threads
1,129,685
Messages
5,637,803
Members
416,983
Latest member
LessThanAverageUser

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
Top