Excel help - Extract Top3 performer Data

M

Mallesh23

Well-known Member
Joined
Feb 4, 2009
Messages
983
Office Version
  1. 2010
Platform
  1. Windows
Hi Team,

I Want to extract top 3 Performer from a list.

Name with ★★★.... Top1 performer
Name with ★★ ..... Top2 Performer
Name with ★ ...... Top3 Peformer


I Receive daily one file, from which I have to extract Top 3 performer.
sometimes we receive more than one top performance in TOP1/ Top2/ Top3.

We need to show both performance name with seperator.


Column A and B my input Columns , which I update Manually.
Column D is Constant Emp Name
Column E is Count no of Times emp name appeared in Column B.


Need Excel formula to show Top1,Top2 and Top3 Columns(G,H,I)
from Column A and B.

Attached are sample input with expected output Column (E:I) D is Constant.

Book1
ABCDEFGHI
1Date(DD/MM/YYYY)Emp PerfomanceEMP NameTop Performer Appereance for NovemberDate(DD/MM/YYYY)Top1(★★★)Top2(★★)Top3(★)
208/11/2020MS Dhoni★★★Rohit Sharma208/11/2020MS DhoniVirat KohliRohit Sharma/Sachin Tendulkar
308/11/2020MS Dhoni★★★MS Dhoni209/11/2020MS Dhoni/Virat KohliRohit SharmaSachin Tendulkar/Manish Pandey
408/11/2020Virat Kohli★★Virat Kohli2
508/11/2020Rohit Sharma★Sachin Tendulkar2
608/11/2020Sachin Tendulkar★Sehwag0
709/11/2020MS Dhoni★★★Manish Pandey1
809/11/2020Virat Kohli★★★Yuvraj0
909/11/2020Rohit Sharma★★
1009/11/2020Sachin Tendulkar★
1109/11/2020Manish Pandey★
Sheet1


Thanks
mg
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Hi Team,

I am ok with solution with VBA \Excel as well.


Thanks
mg
 
Upvote 0
VBA Code: 
Option Explicit
Sub test()

    Dim s1 As Worksheet, i&, ii&, krt$, kys, itms, stars%, y

    Set s1 = ActiveSheet
    s1.Range("D2:I" & Rows.Count).ClearContents
    s1.Copy after:=Sheets(1)
    Range("D:M").Clear
    With CreateObject("VBScript.RegExp")
        .Pattern = "[^\w^\s]+"
        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            Cells(i, 3).Value = Cells(i, 1).Value
            Cells(i, 4).Value = .Replace(Cells(i, 2).Value, "")
        Next i
        .Pattern = "[\w\s]+"
        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            Cells(i, 5).Value = .Replace(Cells(i, 2).Value, "")
            Cells(i, 6).Value = Len(Cells(i, 5).Value)
        Next i
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 2 To Cells(Rows.Count, 4).End(3).Row
            krt = Cells(i, 4).Value
            .Item(krt) = .Item(krt) + 1
        Next i
        kys = Application.Transpose(.keys)
        itms = Application.Transpose(.items)
        Range("H2").Resize(UBound(kys)).Value = kys
        Range("I2").Resize(UBound(itms)).Value = itms
        Range("H2:I" & Cells(Rows.Count, "H").End(3).Row).Sort Range("I2"), xlDescending, Range("H2"), , xlAscending
        .RemoveAll
        Dim w(1 To 4)
        For i = 2 To Cells(Rows.Count, 4).End(3).Row
            krt = Cells(i, 3).Value
            stars = Cells(i, 6).Value
            If Not .exists(krt) Then
                w(1) = krt
                .Item(krt) = w
            End If
            y = .Item(krt)
            y(5 - stars) = y(5 - stars) & "/" & Cells(i, 4).Value
            .Item(krt) = y
        Next i
        itms = .items
    End With
    For i = 0 To UBound(itms)
        y = itms(i)
        Cells(i + 2, "J").Value = y(1)
        For ii = 2 To 4
            Cells(i + 2, ii + 9).Value = IIf(y(ii) <> "", Mid(y(ii), 2), "")
        Next ii
    Next i

    Range("J2:M" & Cells(Rows.Count, "J").End(3).Row).Sort Range("J2"), xlAscending
    Range("H2:M2").CurrentRegion.Copy s1.Range("D2")

    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
    s1.Select
    Columns.AutoFit
End Sub
 
Upvote 0
Hi veyselemre,

Your code is working on data shared.

If I modify data, getting error at line

y(5 - stars) = y(5 - stars) & "/" & wsDest.Cells(i, 4).Value​





VBA Code: 
Option Explicit
Sub Format_Data()
    Dim s1 As Worksheet, i&, ii&, krt$, kys, itms, stars%, y

    Dim wbk As Workbook
    Set wbk = ThisWorkbook
    
    Dim wsData As Worksheet
    Set wsData = wbk.Worksheets("Data")
    
    Dim wsDest As Worksheet
               
    
    wsData.Range("D2:I" & wsData.Rows.Count).ClearContents
    wsData.Copy after:=wbk.Worksheets(wsData.Name)
    Set wsDest = wbk.ActiveSheet
    
    
    
    wsDest.Range("D:M").Clear
    wsDest.Name = "Output"
    
        With CreateObject("VBScript.RegExp")
        .Pattern = "[^\w^\s]+"
        For i = 2 To wsDest.Cells(Rows.Count, 2).End(3).Row
            wsDest.Cells(i, 3).Value = wsDest.Cells(i, 1).Value
            wsDest.Cells(i, 4).Value = .Replace(wsDest.Cells(i, 2).Value, "")
        Next i
        .Pattern = "[\w\s]+"
        For i = 2 To wsDest.Cells(Rows.Count, 2).End(3).Row
            wsDest.Cells(i, 5).Value = .Replace(wsDest.Cells(i, 2).Value, "")
            wsDest.Cells(i, 6).Value = Len(wsDest.Cells(i, 5).Value)
        Next i
    End With

    With CreateObject("Scripting.Dictionary")
        For i = 2 To wsDest.Cells(Rows.Count, 4).End(3).Row
            krt = wsDest.Cells(i, 4).Value
            .Item(krt) = .Item(krt) + 1
        Next i
        kys = Application.Transpose(.keys)
        itms = Application.Transpose(.items)
        wsDest.Range("H2").Resize(UBound(kys)).Value = kys
        wsDest.Range("I2").Resize(UBound(itms)).Value = itms
        wsDest.Range("H2:I" & wsDest.Cells(wsDest.Rows.Count, "H").End(3).Row).Sort wsDest.Range("I2"), xlDescending, wsDest.Range("H2"), , xlAscending
        .RemoveAll
        Dim w(1 To 4)
        For i = 2 To wsDest.Cells(Rows.Count, 4).End(3).Row
            krt = wsDest.Cells(i, 3).Value
            stars = wsDest.Cells(i, 6).Value
            If Not .exists(krt) Then
                w(1) = krt
                .Item(krt) = w
            End If
            y = .Item(krt)
            y(5 - stars) = y(5 - stars) & "/" & wsDest.Cells(i, 4).Value
            .Item(krt) = y
        Next i
        itms = .items
    End With
    For i = 0 To UBound(itms)
        y = itms(i)
        wsDest.Cells(i + 2, "J").Value = y(1)
        For ii = 2 To 4
            wsDest.Cells(i + 2, ii + 9).Value = IIf(y(ii) <> "", Mid(y(ii), 2), "")
        Next ii
    Next i

    wsDest.Range("J2:M" & wsDest.Cells(wsDest.Rows.Count, "J").End(3).Row).Sort wsDest.Range("J2"), xlAscending
    wsDest.Range("H2:M2").CurrentRegion.Copy wsData.Range("D2")

    Application.DisplayAlerts = False
    wsDest.Delete
    Application.DisplayAlerts = True
    wsData.Select
    Columns.AutoFit
End Sub

Below is the data , I was trying to run macro on.

Top Perfomance.xlsm
ABCDEFGHI
1Date(DD/MM/YYYY)Emp PerfomanceEMP NameTop Performer Appereance for NovemberDate(DD/MM/YYYY)Top1(★★★)Top2(★★)Top3(★)
244143Prashant Patil★★★
344143Prashant Patil★★★
444143Akshay Bhatt★★
544143Reshma Patil★
644143Aarti Joshi★
744144MS Dhoni★★★
844144Virat Kohli★★★
944144Rohit Sharma★★
1044144Sachin Tendulkar★
1144144Manish Pandey★
Data





Thanks
mg
 
Upvote 0
maybe without columns D & E will be enough

Date(DD/MM/YYYY)Emp PerfomanceDate(DD/MM/YYYY)★★★★★★
08/11/2020MS Dhoni★★★08/11/2020MS DhoniVirat KohliRohit Sharma / Sachin Tendulkar
08/11/2020MS Dhoni★★★09/11/2020MS Dhoni / Virat KohliRohit SharmaSachin Tendulkar / Manish Pandey
08/11/2020Virat Kohli★★
08/11/2020Rohit Sharma★
08/11/2020Sachin Tendulkar★
09/11/2020MS Dhoni★★★
09/11/2020Virat Kohli★★★
09/11/2020Rohit Sharma★★
09/11/2020Sachin Tendulkar★
09/11/2020Manish Pandey★
 
Last edited:
Upvote 0
continued from previous post...
Power Query: 
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Date = Table.TransformColumnTypes(Source,{{"Date(DD/MM/YYYY)", type date}, {"Emp Perfomance", type text}}),
    stars = Table.AddColumn(Date, "stars", each Text.Select([Emp Perfomance],{"★"})),
    emp = Table.AddColumn(stars, "Emp", each Text.Select([Emp Perfomance],{"a".."z","A".."Z"," "})),
    Distinct = Table.Distinct(emp),
    Group = Table.Group(Distinct, {"Date(DD/MM/YYYY)", "stars"}, {{"Count", each _, type table}}),
    List = Table.AddColumn(Group, "Custom", each [Count][Emp]),
    Extract = Table.TransformColumns(List, {"Custom", each Text.Combine(List.Transform(_, Text.From), " / "), type text}),
    RC = Table.RemoveColumns(Extract,{"Count"}),
    Pivot = Table.Pivot(RC, List.Distinct(RC[stars]), "stars", "Custom")
in
    Pivot
 
Upvote 0
Hi veyselemre and Sandy,

I am still getting error at below line , it works on first data, but if I modify data, getting error at this line.
y(5 - stars) = y(5 - stars) & "/" & wsDest.Cells(i, 4).Value .... unable to identify issue. as its in array and dictionary.

Sandy666 - The answer you have given I don't know how to run on it as I don't have powerquery installed, and NO idea how to use it.



Thanks
mg
 
Upvote 0
Mallesh23 said:
The answer you have given I don't know how to run on it as I don't have powerquery installed, and NO idea how to use it.
Click to expand...

for future:
XL2010/2013

Download Microsoft Power Query for Excel from Official Microsoft Download Center

www.microsoft.com www.microsoft.com
docs.microsoft.com

Power Query documentation - Power Query

Power Query is used to filter, combine, and mash up data from one or more supported data sources.
docs.microsoft.com

Date(DD/MM/YYYY)Emp PerfomanceEmpCountDate(DD/MM/YYYY)★★★★★★
08/11/2020MS Dhoni★★★MS Dhoni308/11/2020MS DhoniVirat KohliRohit Sharma / Sachin Tendulkar
08/11/2020MS Dhoni★★★Virat Kohli209/11/2020MS Dhoni / Virat KohliRohit SharmaSachin Tendulkar / Manish Pandey
08/11/2020Virat Kohli★★Rohit Sharma210/11/2020Penny / MomoLordGod / Lagerfield / MomoFranco / Racoon / Kiribati
08/11/2020Rohit Sharma★Sachin Tendulkar2
08/11/2020Sachin Tendulkar★Manish Pandey1
09/11/2020MS Dhoni★★★Franco1
09/11/2020Virat Kohli★★★Penny1
09/11/2020Rohit Sharma★★Momo2
09/11/2020Sachin Tendulkar★LordGod1
09/11/2020Manish Pandey★Racoon1
10/11/2020Franco★Kiribati1
10/11/2020Penny★★★Lagerfield1
10/11/2020Momo★★★
10/11/2020LordGod★★
10/11/2020Racoon★
10/11/2020Kiribati★
10/11/2020Lagerfield★★
10/11/2020Momo★★
 
Upvote 0
Hi veyselemre

Can you help me , your code is working on data shared. #1
  • If I modify data, getting error at line... I am unable to sort it , Can you look into if you have time.

y(5 - stars) = y(5 - stars) & "/" & wsDest.Cells(i, 4).Value​



Thanks
mg
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
vba help - Split data seperator Black Star
Replies
7
Views
439
Mallesh23
M
M
  • Question Question
vba help - extract last name
Replies
7
Views
621
Mallesh23
M
M
  • Question Question
vba Collection/Dictionary Summarise Data
Replies
6
Views
458
mumps
mumps
M
  • Question Question
vba help - advanced filter
Replies
3
Views
414
JLGWhiz
JLGWhiz
G
  • Question Question
Performance issue in extracting data from excel file (find folder)
Replies
0
Views
955
Gary Powers
G

Forum statistics

Threads
1,224,005
Messages
6,175,910
Members
452,682
Latest member
ghorne

Share this page

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
Back
Top