Combined ranking from multiple workbooks

[dartistik]

Hello all,

Last year I posted a question on here:

https://www.mrexcel.com/forum/excel...ng-automatically-after-entering-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!

 

[Eric W]

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:

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 [COLOR=#ff0000]20000[/COLOR], 1 To 9), wktab As Variant, avg As Double, ix as long

' Initialization
    MyPath = "[COLOR=#ff0000]C:\Users\xxxxx\Documents\Excel\Divisions\[/COLOR]"
    
    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("[COLOR=#ff0000]Samlet rangliste[/COLOR]").Select
        avg = Range("[COLOR=#ff0000]Y7[/COLOR]").Value
        wktab = Range("A1").Resize(Cells(Rows.Count, "[COLOR=#ff0000]D[/COLOR]").End(xlUp).Row, [COLOR=#ff0000]15[/COLOR]).Value
        For r = 2 To UBound(wktab)
            lnum = wktab(r, [COLOR=#ff0000]4[/COLOR])
            If Not Dict.exists(lnum) Then
                MyRow = MyRow + 1
                Dict.Add lnum, MyRow
                ix = MyRow
                Licenses(ix, [COLOR=#ff0000]1[/COLOR]) = ix
                Licenses(ix,[COLOR=#ff0000] 2[/COLOR]) = lnum
                Licenses(ix, [COLOR=#ff0000]3[/COLOR]) = wktab(r, [COLOR=#ff0000]5[/COLOR])
                Licenses(ix, [COLOR=#ff0000]4[/COLOR]) = wktab(r, [COLOR=#ff0000]6[/COLOR])
            Else
                ix = Dict(lnum)
            End If
            Licenses(ix, [COLOR=#ff0000]6[/COLOR]) = Licenses(ix, [COLOR=#ff0000]6[/COLOR]) + wktab(r, [COLOR=#ff0000]11[/COLOR]) + wktab(r, [COLOR=#ff0000]12[/COLOR])
            Licenses(ix, [COLOR=#ff0000]5[/COLOR]) = Licenses(ix, [COLOR=#ff0000]5[/COLOR]) + avg * (wktab(r, [COLOR=#ff0000]11[/COLOR]) + wktab(r, [COLOR=#ff0000]12[/COLOR])) * wktab(r, [COLOR=#ff0000]15[/COLOR])
        Next r
NextFile:
        ActiveWorkbook.Close savechanges:=False
        MyName = Dir()
    Loop

' Finalize scores, get previous scores

    On Error Resume Next
    lr = Cells(Rows.Count, "[COLOR=#ff0000]D[/COLOR]").End(xlUp).Row
    wktab = Range("[COLOR=#ff0000]D4:G[/COLOR]" & lr).Value
    For r = 1 To MyRow
        Licenses(r, [COLOR=#ff0000]5[/COLOR]) = Licenses(r, [COLOR=#ff0000]5[/COLOR]) / Licenses(r, [COLOR=#ff0000]6[/COLOR])
        Licenses(r, [COLOR=#ff0000]6[/COLOR]) = 0
        Licenses(r, [COLOR=#ff0000]6[/COLOR]) = "-"
        Licenses(r, [COLOR=#ff0000]8[/COLOR]) = "-"
        Licenses(r, [COLOR=#ff0000]9[/COLOR]) = "-"
        For i = 1 To UBound(wktab)
            If wktab(i, 1) = Licenses(r, [COLOR=#ff0000]2[/COLOR]) Then
                If Licenses(r, [COLOR=#ff0000]5[/COLOR]) <> wktab(i, 4) Then
                    Licenses(r, [COLOR=#ff0000]6[/COLOR]) = Licenses(r, [COLOR=#ff0000]5[/COLOR]) - wktab(i, 4)
                End If
                Licenses(r, [COLOR=#ff0000]8[/COLOR]) = wktab(i, 4)
                Licenses(r, [COLOR=#ff0000]9[/COLOR]) = i
                Exit For
            End If
        Next i
    Next r
    
    Range("[COLOR=#ff0000]C4[/COLOR]").Resize(UBound(Licenses), UBound(Licenses, 2)) = Licenses
    
' Sort the scores
    With ActiveSheet.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("[COLOR=#ff0000]G4[/COLOR]"), Order:=xlDescending
        .SetRange Range("[COLOR=#ff0000]D4:K[/COLOR]" & 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.

 

[dartistik]

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:

 

[Eric W]

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?

 

[dartistik]

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!

 

[Eric W]

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.

 

[Eric W]

OK, try this version:

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.

 

[dartistik]

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!

 

[Eric W]

Try:

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.

 

[dartistik]

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?