VBA Extract Highest and Second Highest Figures

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

For several days I've been attempting to put together a script which in simple terms finds the 'Highest and Second' highest activity and associated FTE for a given sub group.

To be more specific:

• On the "Slide 1" sheet look at the values in column J starting at row 7 until blank;

• For each value, then search the "All Monthly Direct Activities" sheet in column C for the same value, excluding the 'Subtotal' rows;

• Where a match is found, compare all the values in column E for that sub group;

• And Find the highest and second highest figure;

• Once these are found copy this figure and associated value in column B and paste onto the "slide 1" sheet.

I must admit, I've failed quite miserable, and I just wonder whether someone may be able to look at this please and offer some guidance on how I may go about achieving this.

I appreciate that my description may not be the most straight forward, so I have attached a sample workbook.

This work book shows the 'Source' data on the "All Monthly Direct Activities" sheet and the 'Destination', "Slide 1" sheet. The cells in orange are the expected outcome from the 'Source' sheet.

Many thanks and kind regards

[Solus Rankin]

Maybe

Sub FindThese()
Dim rng1 As Range
Dim rng2 As Range
Dim l As Long
Dim rngMax As Range

Application.ScreenUpdating = False

For Each rng1 In Sheets(2).Range("J7:J" & Sheets(2).Range("J" & Rows.Count).End(xlUp).Row)
    For Each rng2 In Sheets(1).Range("C5:C" & Sheets(1).Range("C" & Rows.Count).End(xlUp).Row)
        If rng2.Value = rng1.Value Then
            Sheets(1).Activate
            rng2.Select
            l = 0
            Do Until ActiveCell.Offset(1).Value <> ActiveCell.Value
                l = l + 1
                ActiveCell.Offset(1).Select
            Loop
            Set rngMax = Sheets(1).Range(Cells(rng2.Row, 5), Cells(rng2.Row + l, 5))
            rng1.Offset(, 2).Value = Application.WorksheetFunction.Max(rngMax)
            rng1.Offset(, 4).Value = Application.WorksheetFunction.Large(rngMax, 2)
            Exit For
        End If
    Next rng2
Next rng1

Application.ScreenUpdating = True
        
End Sub

[hobbiton73]

Hi @Solus Rankin, thank you very much for taking the time to reply to my post and for the code, it's exactly what I was after.

All the very best and kind regards

[hobbiton73]

Hi @Solus Rankin, thank you very much for taking the time to reply to my post and for the code, it's exactly what I was after.

All the very best and kind regards

[Solus Rankin]

Glad to help!

[hobbiton73]

Hi @Solus Rankin, I'm sorry to trouble you again, but I've taking a closer look at the code you kindly provided and unfortunately I'm coming up against is a slight problem.

I've run the several times, and although the correct 'Highest' and 'Second Highest figures are correctly extracted, the associated Activity Description in column B of the 'Source' sheet is not.

I just wondered whether you may be able to look at this please.

Many thanks and kind regards

[apo]

Hi..

Solus Rankin..

I attempted to modify your code... it seems to work...

http://www.ozgrid.com/forum/showthre...d=1#post693011

[Solus Rankin]

apo,

Thank you for posting a response on here.