Getting Top 4 ave percantages for each group in list

[dangb]

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

 

[Arithos]

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?

 

[dangb]

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

 

[MickG]

Try this:- Results sheet2.

[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]
        .Add Dn.Value, Dn
    [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

 

[Arithos]

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.

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
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Arange _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Brange _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Srange
        .Header = xlGuess
        .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 =)