Page 1 of 2 12 LastLast
Results 1 to 10 of 19

Thread: Combined ranking from multiple workbooks
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    May 2017
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Combined ranking from multiple workbooks

    Hello all,

    Last year I posted a question on here:

    https://www.mrexcel.com/forum/excel-...-new-data.html

    and in a matter of a couple of weeks I had a brilliant solution to my problem, thanks to a user called @B___P!

    I now have another project in mind, and I could sure use some more help...

    Once again I don't know if it is even possible to do what I would like, but here goes.


    We currently have 22 divisions in our darts league pyramid in Denmark, and I would like to do a combined ranking of all the players across all divisions.

    I have tried and tested how I want the ranking to work, but manually making a list of ~4,000 players and updating it every time they have played would be an impossible task. I need some automation.


    First of all, I need to make the list of all the players in 22 specific workbooks (one for each division):

    - Scan the 22 workbooks for players by their unique license number (column D in the sheet named 'Samlet rangliste' in all the workbooks)
    - List all players in another workbook called 'Rangliste' with the following information:


    a) License (column D in 'Samlet rangliste' in all the workbooks) in column D
    b) Name (column E in 'Samlet rangliste' in all the workbooks) in column E
    c) Club (column F in 'Samlet rangliste' in all the workbooks) in column F
    d) Score in column G

    - The 'Score' should be calculated in the following way:


    a) If the player has only played in one division (license number only found in one workbook) it is fairly easy:
    The player's rating (column O in the sheet 'Samlet rangliste') x The average rating for the division (cell Y7 in the sheet 'Samlet rangliste')

    b) If the player has played in several divisions (license number found in multiple workbooks):
    As above, but as a percentage of the total number of legs played in each division, for example:

    Player A has played 10 legs in 1. division (column K+L in the sheet 'Samlet rangliste' in the workbook '1. division')
    Player A has played 20 legs in 2. division Vest (column K+L in the sheet 'Samlet rangliste' in the workbook '2. division Vest')
    He has then played 30 legs in total (columns K+L in 'Samlet rangliste' in both workbooks)


    It should then be (10/30) x his rating in 1. division (column O in 'Samlet rangliste' in the workbook '1. division') x the average rating for that division (cell Y7) + (20/30) x his rating in 2. division Vest (column O in 'Samlet rangliste' in the workbook '2. division Vest') x the average rating for that division (cell Y7)


    And so forth for all players who have played in multiple divisions (some may have played in more than two different divisions as well).


    Once the initial list has been built, I need the option to update the list every time the players have played in matches:

    - Scan the 22 workbooks for license numbers and update the existing numbers correspondingly
    - Add any new players not already in the list to the list using the same method as above, also adding a "-" in column J and K for the new players


    Right, if anyone has even bothered to read that massive chunk of text, I'd be happy to send any info needed to anyone willing to give it a shot. I don't know if I explained it well enough or if it is in any way doable, but if it isn't then I'll at least know that.


    Please don't hesitate to get in touch with any comments and I'd be most grateful!

  2. #2
    MrExcel MVP Eric W's Avatar
    Join Date
    Aug 2015
    Location
    Bountiful, UT
    Posts
    8,644
    Post Thanks / Like
    Mentioned
    42 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    No doubt I've misunderstood some things, but here's a shot at it.

    Open a brand new workbook, and set up the first sheet as shown from your post, rows and columns as shown. Open the VBA editor (Alt-F11) and add this code to a new general module:

    Code:
    Public Sub RankScores()
    Dim MyPath As String, MyName As String
    Dim MyRow As Long, r As Long, i As Long, lnum As Long, Dict As Object
    Dim Licenses(1 To 20000, 1 To 9), wktab As Variant, avg As Double, ix as long
    
    ' Initialization
        MyPath = "C:\Users\xxxxx\Documents\Excel\Divisions\"
        
        Set Dict = CreateObject("Scripting.Dictionary")
        
        MyName = Dir(MyPath & "*.xl*")
        MyRow = 0
        
        Application.ScreenUpdating = False
        
    ' Find all the matching files in this directory.  get the scores
        On Error GoTo CloseIt:
        Do While MyName <> ""
            Workbooks.Open Filename:=MyPath & MyName
            Sheets("Samlet rangliste").Select
            avg = Range("Y7").Value
            wktab = Range("A1").Resize(Cells(Rows.Count, "D").End(xlUp).Row, 15).Value
            For r = 2 To UBound(wktab)
                lnum = wktab(r, 4)
                If Not Dict.exists(lnum) Then
                    MyRow = MyRow + 1
                    Dict.Add lnum, MyRow
                    ix = MyRow
                    Licenses(ix, 1) = ix
                    Licenses(ix, 2) = lnum
                    Licenses(ix, 3) = wktab(r, 5)
                    Licenses(ix, 4) = wktab(r, 6)
                Else
                    ix = Dict(lnum)
                End If
                Licenses(ix, 6) = Licenses(ix, 6) + wktab(r, 11) + wktab(r, 12)
                Licenses(ix, 5) = Licenses(ix, 5) + avg * (wktab(r, 11) + wktab(r, 12)) * wktab(r, 15)
            Next r
    NextFile:
            ActiveWorkbook.Close savechanges:=False
            MyName = Dir()
        Loop
    
    ' Finalize scores, get previous scores
    
        On Error Resume Next
        lr = Cells(Rows.Count, "D").End(xlUp).Row
        wktab = Range("D4:G" & lr).Value
        For r = 1 To MyRow
            Licenses(r, 5) = Licenses(r, 5) / Licenses(r, 6)
            Licenses(r, 6) = 0
            Licenses(r, 6) = "-"
            Licenses(r, 8) = "-"
            Licenses(r, 9) = "-"
            For i = 1 To UBound(wktab)
                If wktab(i, 1) = Licenses(r, 2) Then
                    If Licenses(r, 5) <> wktab(i, 4) Then
                        Licenses(r, 6) = Licenses(r, 5) - wktab(i, 4)
                    End If
                    Licenses(r, 8) = wktab(i, 4)
                    Licenses(r, 9) = i
                    Exit For
                End If
            Next i
        Next r
        
        Range("C4").Resize(UBound(Licenses), UBound(Licenses, 2)) = Licenses
        
    ' Sort the scores
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("G4"), Order:=xlDescending
            .SetRange Range("D4:K" & UBound(Licenses))
            .Apply
        End With
            
    ' finalization
        Application.ScreenUpdating = True
        Exit Sub
    CloseIt:
        Resume NextFile:
    
    End Sub
    Items in red are of particular note. The 20000 is the maximum number of players this will handle. Increase if needed. I assumed that you have all the files in the same folder. Change the MyPath line to the path of that folder. This macro will read every Excel file in that folder, but it will ignore any without a "Samlet rangliste" sheet. The other references are cell or column references.

    See if this works for you.
    Cheers,
    Eric

    When you eliminate the impossible, whatever remains, however improbable, must be the truth.

    -Posting guidelines, forum rules, terms of use, FAQs, BB codes, See how to search the forum
    -Post a screen shot with the HTML Maker

  3. #3
    New Member
    Join Date
    May 2017
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    Hi Eric,

    Thank you so much for giving it a try! I inserted your code in the new workbook and changed the path to where the 22 workbooks are located. When I then ran the macro, it took about 10 seconds and it looks like it then just added 20,000 blank rows to the sheet

    Before:



    After:


  4. #4
    MrExcel MVP Eric W's Avatar
    Join Date
    Aug 2015
    Location
    Bountiful, UT
    Posts
    8,644
    Post Thanks / Like
    Mentioned
    42 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    While writing that macro, I made many assumptions, based on your description. But I built 3 test workbooks in addition to the summary sheet, and the macro worked fine. I expected that you'd get something, but that we'd need to tweak it. If you're not getting anything at all, then there must be some difference in our setups. For example, are you sure that you have the right path name? Do the Excel files have an extension of .xls or .xlsm or .xlsx or .xl*? If it takes 10 seconds, it might actually be opening the files. Is the spelling of the "Samlet ragliste" tabs the same as in the macro? Any extra spaces? On that tab, what row does the data start on? Are there headers? Can you show a sample sheet with data?
    Cheers,
    Eric

    When you eliminate the impossible, whatever remains, however improbable, must be the truth.

    -Posting guidelines, forum rules, terms of use, FAQs, BB codes, See how to search the forum
    -Post a screen shot with the HTML Maker

  5. #5
    New Member
    Join Date
    May 2017
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    Hi Eric,

    I'm sure we can work our way to the right solution - to answer your questions:

    - The path is correct. I had it wrong the first time, and nothing happened when I ran the macro. After correcting it, it thinks for 10-15 seconds (as if it is indeed scanning the target files) and then adds 20,000 rows
    - The file extensions are .xlsm
    - The spelling of 'Samlet rangliste' is correct and the same in all the files (they're all built from the same template sheet)
    - Here's a screenshot of one of the workbooks, where you can see the target columns and cells:



    Column D is the unique license number for all the players, columns E and F are needed to list the player and club names, columns K and L are needed to calculate the number of legs played per division and in total if the player has played in multiple divisions, column O is the rating needed to calculate the players' score, and cell Y9 is the average rating for each division also needed to calculate their score.

    I'd be happy to upload one (or more) of the workbooks if you need it!

  6. #6
    MrExcel MVP Eric W's Avatar
    Join Date
    Aug 2015
    Location
    Bountiful, UT
    Posts
    8,644
    Post Thanks / Like
    Mentioned
    42 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    I'll take a look at it when I can. That looks like my sample books. I may add some code to the macro just to see where it goes wrong. However, after today I'm going to be away for almost 2 weeks. So after today, someone else might jump in, or I'll pick it up again when I get back.
    Cheers,
    Eric

    When you eliminate the impossible, whatever remains, however improbable, must be the truth.

    -Posting guidelines, forum rules, terms of use, FAQs, BB codes, See how to search the forum
    -Post a screen shot with the HTML Maker

  7. #7
    MrExcel MVP Eric W's Avatar
    Join Date
    Aug 2015
    Location
    Bountiful, UT
    Posts
    8,644
    Post Thanks / Like
    Mentioned
    42 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    OK, try this version:

    Code:
    Public Sub RankScores()
    Dim MyPath As String, MyName As String, Status As String
    Dim MyRow As Long, r As Long, i As Long, lnum As Long, Dict As Object
    Dim Licenses(1 To 20000, 1 To 9), wktab As Variant, avg As Double, ix As Long, lr As Long
    
    
    ' Initialization
        MyPath = "C:\Users\xxxxx\Documents\Excel\Licenses\"
        
        Set Dict = CreateObject("Scripting.Dictionary")
        
        MyName = Dir(MyPath & "*.xl*")
        MyRow = 0
        
        Application.ScreenUpdating = False
        
    ' Find all the matching files in this directory.  get the scores
        On Error GoTo CloseIt:
        Do While MyName <> ""
            Status = Status & vbLf & MyName & ": Opening"
            Workbooks.Open Filename:=MyPath & MyName
            Status = Status & vbLf & MyName & ": Checking for Samlet rangliste"
            Sheets("Samlet rangliste").Select
            avg = Range("Y7").Value
            Status = Status & vbLf & MyName & ": average = " & avg
            wktab = Range("A1").Resize(Cells(Rows.Count, "D").End(xlUp).Row, 15).Value
            Status = Status & vbLf & MyName & ": last row in D = " & UBound(wktab)
            savmr = MyRow
            For r = 4 To UBound(wktab)
                lnum = wktab(r, 4)
                If Not Dict.exists(lnum) Then
                    MyRow = MyRow + 1
                    Dict.Add lnum, MyRow
                    ix = MyRow
                    Licenses(ix, 1) = ix
                    Licenses(ix, 2) = lnum
                    Licenses(ix, 3) = wktab(r, 5)
                    Licenses(ix, 4) = wktab(r, 6)
                Else
                    ix = Dict(lnum)
                End If
                Licenses(ix, 6) = Licenses(ix, 6) + wktab(r, 11) + wktab(r, 12)
                Licenses(ix, 5) = Licenses(ix, 5) + avg * (wktab(r, 11) + wktab(r, 12)) * wktab(r, 15)
            Next r
            Status = Status & vbLf & MyName & ": licenses added = " & MyRow - savmr
    NextFile:
            Status = Status & vbLf & MyName & ": closing"
            ActiveWorkbook.Close savechanges:=False
            MyName = Dir()
            Status = Status & vbLf
        Loop
    
    
    ' Finalize scores, get previous scores
    
    
        Status = Status & vbLf & "Going though table, licenses = " & MyRow
        On Error Resume Next
        lr = Cells(Rows.Count, "D").End(xlUp).Row
        Status = Status & vbLf & "count of existing licenses = " & lr - 3
        wktab = Range("D4:G" & lr).Value
        For r = 1 To MyRow
            Licenses(r, 5) = Licenses(r, 5) / Licenses(r, 6)
            Licenses(r, 6) = "-"
            Licenses(r, 8) = "-"
            Licenses(r, 9) = "-"
            For i = 1 To UBound(wktab)
                If wktab(i, 1) = Licenses(r, 2) Then
                    If Licenses(r, 5) <> wktab(i, 4) Then
                        Licenses(r, 6) = Licenses(r, 5) - wktab(i, 4)
                    End If
                    Licenses(r, 8) = wktab(i, 4)
                    Licenses(r, 9) = i
                    Exit For
                End If
            Next i
        Next r
        
        Status = Status & vbLf & "Writing table to worksheet"
        Range("C4").Resize(UBound(Licenses), UBound(Licenses, 2)) = Licenses
        
        Status = Status & vbLf & "Sorting table"
    ' Sort the scores
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("G4"), Order:=xlDescending
            .SetRange Range("D4:K" & UBound(Licenses))
            .Apply
        End With
            
    ' finalization
        Application.ScreenUpdating = True
        MsgBox Status
        Exit Sub
    CloseIt:
        Status = Status & vbLf & MyName & ": error"
        Resume NextFile:
    
    
    End Sub
    I found one minor difference in your sheet and my test sheets, the licenses started on row 4 and I started on 2. Not sure how much of a difference that would have made, but I fixed it. I also added a status message that says pretty much everything it does. Looking at that should tell us what's not working right. If this iteration happens to work, you can delete the "Msgbox status" line near the end. And if you really want to clean it up, remove all the "Status =" lines throughout.

    Good luck! I'll check when I get back to see where this is at.
    Cheers,
    Eric

    When you eliminate the impossible, whatever remains, however improbable, must be the truth.

    -Posting guidelines, forum rules, terms of use, FAQs, BB codes, See how to search the forum
    -Post a screen shot with the HTML Maker

  8. #8
    New Member
    Join Date
    May 2017
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    Hi Eric,

    We're definitely getting somewhere now!

    This is how it looked when I ran the macro this time:



    Things to note:
    - Formatting issues - is it possible to keep the formatting when adding new players to the list? It also looks like the macro is adding a "-" in column H, that should only be in columns J and K (and only for new players), as I have a formula in column H that when a new player is added reads "NEW".

    - The macro still adds 20,000 rows to the sheet even when the number of active players in the scanned workbooks is only 1,369 at the moment. It would be great if it only added the actual number of rows for new players.

    - Also, the numbers in column G should be kept at 2 decimals - it is correctly for the players added to the 7 rows already formatted, but all the others are not rounded (The players in 8th and 18th position in the picture were in the formatted area after the macro scanned the first workbook as they are 1st division players, but have then been displaced as it worked its way through the other workbooks).


    Enjoy what you're doing for the next couple if weeks and we'll pick it up again Stellar work so far, hadn't imagined being this close to what I needed already!

  9. #9
    MrExcel MVP Eric W's Avatar
    Join Date
    Aug 2015
    Location
    Bountiful, UT
    Posts
    8,644
    Post Thanks / Like
    Mentioned
    42 Post(s)
    Tagged
    5 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    Try:

    Code:
    Public Sub RankScores()
    Dim MyPath As String, MyName As String, Status As String
    Dim MyRow As Long, r As Long, i As Long, lnum As Long, Dict As Object
    Dim Licenses(1 To 20000, 1 To 9), wktab As Variant, avg As Double, ix As Long, lr As Long
    Dim L2() As Variant
    
    ' Initialization
        MyPath = "C:\Users\eweeks\Documents\Excel\Students\"
        
        Set Dict = CreateObject("Scripting.Dictionary")
        
        MyName = Dir(MyPath & "*.xl*")
        MyRow = 0
        
        Application.ScreenUpdating = False
        
    ' Find all the matching files in this directory.  get the scores
        On Error GoTo CloseIt:
        Do While MyName <> ""
            Workbooks.Open Filename:=MyPath & MyName
            Sheets("Samlet rangliste").Select
            avg = Range("Y7").Value
            wktab = Range("A1").Resize(Cells(Rows.Count, "D").End(xlUp).Row, 15).Value
            savmr = MyRow
            For r = 4 To UBound(wktab)
                lnum = wktab(r, 4)
                If Not Dict.exists(lnum) Then
                    MyRow = MyRow + 1
                    Dict.Add lnum, MyRow
                    ix = MyRow
                    Licenses(ix, 1) = ix
                    Licenses(ix, 2) = lnum
                    Licenses(ix, 3) = wktab(r, 5)
                    Licenses(ix, 4) = wktab(r, 6)
                Else
                    ix = Dict(lnum)
                End If
                Licenses(ix, 6) = Licenses(ix, 6) + wktab(r, 11) + wktab(r, 12)
                Licenses(ix, 5) = Licenses(ix, 5) + avg * (wktab(r, 11) + wktab(r, 12)) * wktab(r, 15)
            Next r
    NextFile:
            ActiveWorkbook.Close savechanges:=False
            MyName = Dir()
        Loop
    
    ' Finalize scores, get previous scores
    
        On Error Resume Next
        lr = Cells(Rows.Count, "D").End(xlUp).Row
        wktab = Range("D4:G" & lr).Value
        ReDim L2(1 To MyRow, 1 To 9)
        For r = 1 To MyRow
            Licenses(r, 5) = Licenses(r, 5) / Licenses(r, 6)
            Licenses(r, 6) = ""
            Licenses(r, 8) = "-"
            Licenses(r, 9) = "-"
            For i = 1 To UBound(wktab)
                If wktab(i, 1) = Licenses(r, 2) Then
                    If Licenses(r, 5) <> wktab(i, 4) Then
                        Licenses(r, 6) = Licenses(r, 5) - wktab(i, 4)
                    End If
                    Licenses(r, 8) = wktab(i, 4)
                    Licenses(r, 9) = i
                    Exit For
                End If
            Next i
            For i = 1 To 9
                L2(r, i) = Licenses(r, i)
            Next i
        Next r
        
        Range("C4").Resize(UBound(L2), UBound(L2, 2)) = L2
        
    ' Sort the scores
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Range("G4"), Order:=xlDescending
            .SetRange Range("D4:K" & UBound(L2))
            .Apply
        End With
            
    ' finalization
        Application.ScreenUpdating = True
        Exit Sub
        
    CloseIt:
        Resume NextFile:
    
    End Sub
    The macro does no formatting. If you select a column and apply the formatting you want, including number of decimals, then it should stick even after running the macro. Your rows 8 and 18 look like what happens when you cut and paste cells, which this macro does not do.

    In column H, I have to put something. If not an actual difference, then a dash, or an empty cell, or the word "NEW". Change the line in red if you want. If you put a formula in that column, it will get overwritten. You could do something with Conditional Formatting if you really want.

    The macro now only writes as many rows as it needs. This actually could cause problems if you delete players, which is why I didn't see adding extra rows at the end as a problem. But it's up to you.
    Cheers,
    Eric

    When you eliminate the impossible, whatever remains, however improbable, must be the truth.

    -Posting guidelines, forum rules, terms of use, FAQs, BB codes, See how to search the forum
    -Post a screen shot with the HTML Maker

  10. #10
    New Member
    Join Date
    May 2017
    Posts
    16
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Combined ranking from multiple workbooks

    Hi Eric,

    I just now had time to test this. Sure enough, if I manually do all the formatting for all ~1,400 rows, the list looks decent when I run the macro.

    So, I pretty much have the initial list to base these rankings on. Now, when the next round of fixtures is played and I run the macro again afterwards, it will update the score of the players already in the list and add any new players, right?

    The macro should only add the "-" in columns J and K for any NEW players added to the list. These columns are used to track any changes in score and position on the list, so I copy every players previous score and position to here before updating the list. That's why I'd like for column H to be "undisturbed" by the macro, as the formula in this will tell you any increase/decrease in the players score compare to the last time.

    EDIT: Just for fun I tried running the macro again with no changes to the players' score in the target workbooks of course, and I noticed it takes the players previous score and position and copies to columns J and K by itself. That is great as I don't need to do that beforehand then! Only problem now is that the formula in column H gets overwritten - is there no way to change that?

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •