# Getting Top 4 ave percantages for each group in list

#### dangb

##### New Member
 A B USE 102.56% USE 87.34% USE 72.56% FIN 86.5% BAE 90.56% BAE 70.45% BAE 69.67% BAE 68.45% BAE 75.56% BAE 65.12%

<tbody>
</tbody>
Hi All , In vba I'm trying to find the best way to be able to extract the top 4 percentages (and average them) for each of the groups in col A. an then paste the average and Group code to another sheet in order. anyone an good idea how to go about it?

thanks

Dan

### Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
 A B USE 102.56% USE 87.34% USE 72.56% FIN 86.5% BAE 90.56% BAE 70.45% BAE 69.67% BAE 68.45% BAE 75.56% BAE 65.12%

<tbody>
</tbody>
Hi All , In vba I'm trying to find the best way to be able to extract the top 4 percentages (and average them) for each of the groups in col A. an then paste the average and Group code to another sheet in order. anyone an good idea how to go about it?

thanks

Dan

You want to "Sort out" Every group from Column A, and then Average the top 4 values, for each group?

What if there are less then 4 observations per group?

You want to "Sort out" Every group from Column A, and then Average the top 4 values, for each group?

What if there are less then 4 observations per group?

Hi Arithos,

thanks for your time -yes sort out every group and average top 4 values...if under 4 in total then average out number available.

cheers

dn

Try this:- Results sheet2.
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG08Sep42
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K
[COLOR="Navy"]Dim[/COLOR] Nu          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oSum        [COLOR="Navy"]As[/COLOR] Double
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Else[/COLOR]
[COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
Nu = IIf(.Item(K).Count >= 4, 4, .Item(K).Count)
[COLOR="Navy"]For[/COLOR] n = 1 To Nu
oSum = oSum + Application.Large(.Item(K).Offset(, 1), n)
[COLOR="Navy"]Next[/COLOR] n

[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
c = c + 1
.Rows(c).Range("A1:B1") = Array(K, Format(oSum / Nu, "0.00%"))
oSum = 0
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] K

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

Hi Arithos,

thanks for your time -yes sort out every group and average top 4 values...if under 4 in total then average out number available.

cheers

dn

Then I understood correctly. This is what I got for you.

Code:
``````Sub Sortering_Flytting()
' Sortering_Flytting Macro
LR = Cells(Rows.Count, 1).End(xlUp).Row
Dim Srange As Range, Arange As Range, Brange As Range
Set Srange = Range("A1:B" & LR)
Set Arange = Range("A1:A" & LR)
Set Brange = Range("B1:B" & LR)

ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Srange
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With   ' All the above sorts column A and B

CountIt = 1
j = 1
For x = 1 To LR
If Cells(x, 1).Value <> Cells(x + 1, 1).Value Then
j = j + 3
Range(Cells(CountIt, 1), Cells(x, 2)).Copy Cells(1, j)    'moves the sorted values
CountIt = x + 1
End If
Next x

LC = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column

For i = 6 To LC Step 3

Cells(1, i).FormulaR1C1 = "=Average(RC[-1]:R[3]C[-1])" 'Inserts the Average Formula

Next

End Sub``````

Change references in code to move it to another sheet. Other then that it is close to what you want. I dont have time to raffine it, I just threw something together to get you started =)

Replies
0
Views
499
Replies
1
Views
11K
Replies
12
Views
667
Replies
2
Views
277
Replies
1
Views
2K

1,220,951
Messages
6,157,030
Members
451,392
Latest member
malcv

### 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.

### Which adblocker are you using?

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

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