Looking to improve efficiency of code

[DonEB]

The following code was taken from a macro I have been working on .... most of which is due to the help of people within this Forum... so thank you. Unfortunately, it takes over 60 seconds to run. I can't blame those who helped me in the past because I never conveyed the entire scope of the project and was just looking to learn some macro tricks with the hopes that it may solve my problem. Since this code only reflects one part of the overall task that needs to be done, finding a faster way to complete this task is essential.

So, the question is... is there a more efficient way to perform the task I'm performing below using VBA within Excel? Any thoughts on how to reduce processing time would be appreciated. Since there are generally 13 weeks in a quarter, this process has to be run 13 times... so that means it would take a minimum of 13 minutes to run. That's not good.

A little background...

• This program is being created to assign the "best combination" of 4 players to a tennis court and there could be as many as 5 courts to be filled on any one day.
• Best combination means "those 4 players who have played the least amongst themselves. This "value" is determined as assignments are made to the quarterly schedule. Example: If 2 weeks of play have been completed and player 1 and player 2 have already played against/with each other once then their respective values would be 1 day of play/2 weeks or .50.
• With 5 courts, that would equate to as many as 20 players at one time (4 for each court). In my spreadsheet, I am able to whittle the players down to a top 20 players. When determining how many "combinations" exist for 20 players taken 4 at a time, that equates to 4845.
• Sheets("CommonData").Range("B3:X24") refers to a chart consisting of 22 rows and 23 columns.
• Example of this data is in the Chart below: This is just a snippet... last names are in the second column and second row. And the chart extends to the right and down until a total of 20 players are reflected.
  

  Row\Column	B	C	D	E	F	G	H	I
  3				6	18	17	29	etc
  4				Dumbo	Flair	Elders	Nail	etc
  5	6	Dumbo	0.0001		.5	.5	.5	etc
  6	18	Flair	0.071429	.5		1	0	etc
  7	17	Elders	0.071429	.5	1		0	etc
  8	29	Nail	0.071429	.5	0	0		etc
  9	etc	etc	etc	etc	etc	etc	etc

  
  <tbody>
  </tbody>
• players = Range("G7:K4851") refers to a chart consisting of 4845 rows and 6 columns.
• Example of this data is in the Chart below: This is just a snippet... but the first 4 columns consist of four potential players to be assigned to a court. The fifth column reflects the "value" as determined by the code below. Value between 6 and 18 is .5, between 6 and 17 is .5 and between 6 and 29 is .5 for a total of 1.5.
• Later in the program (not in the code below) this chart is sorted to bring the lowest value in the 5th column to the top. Those would be the best candidates to place on the first court.

• Row\Column	G	H	I	J	K	L
  7	6	18	17	29	1.5	etc
  8	6	18	17	13	1.5	etc
  9	6	18	17	21	1.5	etc
  10	6	18	17	22	1.5	etc
  11	6	18	17	26	1.5	etc
  12	etc	etc	etc	etc	etc	etc

  
  <tbody>
  </tbody>

Here's the code:

Dim Courts5(4845, 6) As Variant 'defines array as being 4845 rows, 6 columns
Dim X As Long
Dim Y As Long

Dim i As Long
Dim j As Long

Dim Total As Variant

inarr = Sheets("CommonData").Range("B3:X24") ' move this outside the loop so that it only executes once


'load all the players data
Sheets("Courts5").Select
players = Range("G7:K4851")

For X = 1 To 4845 Step 1 ' Step thru each row
Total = 0
For Y = 2 To 4 Step 1 ' For each row, step thru each column starting with the second column

VB2 = players(X, Y)
VA2 = players(X, 1) ' Player in 1st column for which the values are being computed.
For i = 1 To 23
If inarr(1, i) = VB2 Then
Exit For ' we have found the column
End If
Next i
For j = 1 To 23
If inarr(j, 1) = VA2 Then
Exit For ' we have found the row
End If
Next j


Courts5(X, Y) = inarr(j, i) 'placing value found using "lookup" in the 5th position of the same array to be used in the future
Total = Total + Courts5(X, Y) 'placing value found using "lookup" in the 5th position of the same array to be used in the future

Next Y

Cells(6 + X, 11).Value = Total 'write computed total to appropriate place within the table
Next X

 

[StephenCrump]

A couple of thoughts ..

Your code does a lot of looping through rows and columns, because you are trying to locate player numbers, e.g. 6, 18, 17 and 29 for the first combination. If you think instead of this first combination as 1,2,3,4, the second as 1,2,3,5 ... and the 4,845th as 17,18,19,20, then you can work direct with these numbers as row and column numbers.

I'm not quite clear how you are scoring? With each combination of 4, aren't there 6 pairings to be tested, e.g. 1,2 | 1,3 | 1,4 | 2,3 | 2,4 | 3,4 ?

Assuming my interpretation is correct, you could code it like this:

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, N As Long, r As Long, i As Long, j As Long
    Dim dScores() As Double
    Dim inarray As Variant
    
    N = 20
    r = 4
 
    lCombinations = GetCombinations(N, r)
    lPairs = GetCombinations(r, 2)
    ReDim dScores(1 To UBound(lCombinations), 1 To 1)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, 1) = dScores(i, 1) + inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
    Next i
    
    'Dump results to check and sort, assuming columns Z:AD are free ..
    With Range("Z1").Resize(UBound(lCombinations))
        .Resize(, r).Value = lCombinations
        .Offset(, r).Value = dScores
    End With

End Sub
Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()

    Dim lOutput() As Long, lCombinations As Long
    Dim i As Long, j As Long, k As Long
    
    lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
    
    For i = 1 To lNoChosen
        lOutput(1, i) = i
    Next i
    
    For i = 2 To lCombinations
        For j = 1 To lNoChosen
            lOutput(i, j) = lOutput(i - 1, j)
        Next j
        For j = lNoChosen To 1 Step -1
            lOutput(i, j) = lOutput(i, j) + 1
            If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
        Next j
        For k = j + 1 To lNoChosen
            lOutput(i, k) = lOutput(i, k - 1) + 1
        Next k
    Next i
    
    GetCombinations = lOutput
    
End Function

Once you've determined the optimum combinations, it will be easy to convert back the player numbers, e.g.
My 1 --> Your 6
My 2 --> Your 18 etc

 

[DonEB]

A couple of thoughts ..

Your code does a lot of looping through rows and columns, because you are trying to locate player numbers, e.g. 6, 18, 17 and 29 for the first combination. If you think instead of this first combination as 1,2,3,4, the second as 1,2,3,5 ... and the 4,845th as 17,18,19,20, then you can work direct with these numbers as row and column numbers.

I'm not quite clear how you are scoring? With each combination of 4, aren't there 6 pairings to be tested, e.g. 1,2 | 1,3 | 1,4 | 2,3 | 2,4 | 3,4 ?

Assuming my interpretation is correct, you could code it like this:

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, N As Long, r As Long, i As Long, j As Long
    Dim dScores() As Double
    Dim inarray As Variant
    
    N = 20
    r = 4
 
    lCombinations = GetCombinations(N, r)
    lPairs = GetCombinations(r, 2)
    ReDim dScores(1 To UBound(lCombinations), 1 To 1)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, 1) = dScores(i, 1) + inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
    Next i
    
    'Dump results to check and sort, assuming columns Z:AD are free ..
    With Range("Z1").Resize(UBound(lCombinations))
        .Resize(, r).Value = lCombinations
        .Offset(, r).Value = dScores
    End With

End Sub
Function GetCombinations(lNumber As Long, lNoChosen As Long) As Long()

    Dim lOutput() As Long, lCombinations As Long
    Dim i As Long, j As Long, k As Long
    
    lCombinations = WorksheetFunction.Combin(lNumber, lNoChosen)
    ReDim lOutput(1 To lCombinations, 1 To lNoChosen)
    
    For i = 1 To lNoChosen
        lOutput(1, i) = i
    Next i
    
    For i = 2 To lCombinations
        For j = 1 To lNoChosen
            lOutput(i, j) = lOutput(i - 1, j)
        Next j
        For j = lNoChosen To 1 Step -1
            lOutput(i, j) = lOutput(i, j) + 1
            If lOutput(i, j) <= lNumber - (lNoChosen - j) Then Exit For
        Next j
        For k = j + 1 To lNoChosen
            lOutput(i, k) = lOutput(i, k - 1) + 1
        Next k
    Next i
    
    GetCombinations = lOutput
    
End Function

Once you've determined the optimum combinations, it will be easy to convert back the player numbers, e.g.
My 1 --> Your 6
My 2 --> Your 18 etc

StephenCrump... you are correct in saying that there are actually six (6) pairings. I had not gotten that far yet but didn't know if it was worth pursuing because the code I had was taking to long to get thru (60 seconds) with only the group of 4. Does the code you provide by chance handle the six (6) pairing? Or might you have a solution that can be added onto your new code to accommodate that issue?

I'm looking forward to giving this new code a try shortly. And I look forward to your response and thanks for your help.

 

[DonEB]

StephenCrump.... just tried this code out and it is fast. And, if I understand it correctly... it does take into account all 6 possible pairings.

It will take me a little while to understand the code you used since I'm not that familiar with it but it works like a charm.

Thank you very much!!

 

[StephenCrump]

Does the code you provide by chance handle the six (6) pairing?

Yes it does.

In the workbook attached, columns AF:AL verify the VBA results against the sum of the six pairings. (I've randomised the scores a little to better illustrate).

https://app.box.com/s/8ww0sag37tb8kj2chxbkw2i5nl6gl1ls

I have added some code to sort the results and convert back from numbers to player names:

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, N As Long, r As Long, i As Long, j As Long
    Dim dScores() As Double
    Dim inarray As Variant, NameList As Variant
    Dim MyNames() As String
    
    N = 20
    r = 4
 
    NameList = Range("MyNames").Value2
    lCombinations = GetCombinations(N, r)
    lPairs = GetCombinations(r, 2)
    ReDim dScores(1 To UBound(lCombinations), 1 To 1)
    ReDim MyNames(1 To UBound(lCombinations), 1 To r)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, 1) = dScores(i, 1) + inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
        For j = 1 To r
            MyNames(i, j) = NameList(1, lCombinations(i, j))
        Next j
    Next i
    
    'Dump results to check and sort, assuming columns Z:AD are free ..
    With Range("Z2").Resize(UBound(lCombinations))
        .Resize(, r).Value = MyNames
        .Offset(, r).Value = dScores
        .Resize(, r + 1).Sort Key1:=.Columns(r+1), Order1:=xlAscending
    End With

End Sub

 

[DonEB]

Yes it does.

In the workbook attached, columns AF:AL verify the VBA results against the sum of the six pairings. (I've randomised the scores a little to better illustrate).

https://app.box.com/s/8ww0sag37tb8kj2chxbkw2i5nl6gl1ls

I have added some code to sort the results and convert back from numbers to player names:

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, N As Long, r As Long, i As Long, j As Long
    Dim dScores() As Double
    Dim inarray As Variant, NameList As Variant
    Dim MyNames() As String
    
    N = 20
    r = 4
 
    NameList = Range("MyNames").Value2
    lCombinations = GetCombinations(N, r)
    lPairs = GetCombinations(r, 2)
    ReDim dScores(1 To UBound(lCombinations), 1 To 1)
    ReDim MyNames(1 To UBound(lCombinations), 1 To r)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, 1) = dScores(i, 1) + inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
        For j = 1 To r
            MyNames(i, j) = NameList(1, lCombinations(i, j))
        Next j
    Next i
    
    'Dump results to check and sort, assuming columns Z:AD are free ..
    With Range("Z2").Resize(UBound(lCombinations))
        .Resize(, r).Value = MyNames
        .Offset(, r).Value = dScores
        .Resize(, r + 1).Sort Key1:=.Columns(r+1), Order1:=xlAscending
    End With

End Sub

StephenCrump.... this is so cool.
I did run into a problem trying to run the new code. I came up with a "Run-Time Error '1004'". Method 'Range' of object '_Global' failed. Here's the code it stopped on. NameList = Range("MyNames").Value2

And this may or may not impact your answer to the above issue... but I really don't need the numbers turned back into Names.... but I do need them turned back into my player numbers. To provide a brief explanation why... due to space limitations on how the Quarterly Tennis Schedule is presented to the players, I use numbers to reflect who's scheduled to play from week to week and below the schedule I have a list of players that correspond to those numbers.

So... instead of changing it back to the names... if it could go back to the original player numbers... that would be great!

I'm truly amazed as to how fast this process is now becoming. What I thought might take minutes to complete, I'm now sensing that it may take seconds. Thanks so much for your help.

Don

 

[StephenCrump]

"Run-Time Error '1004'". Method 'Range' of object '_Global' failed. Here's the code it stopped on. NameList = Range("MyNames").Value2

... but I really don't need the numbers turned back into Names.... but I do need them turned back into my player numbers.

The workbook I attached had a defined name:
MyNames: =CommonData!$E$4:$X$4

Instead, in your workbook define:
MyNumbers: =CommonData!$E$3:$X$3

Then try this slightly modified code:

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, lNumbers() As Long, N As Long, r As Long, i As Long, j As Long
    Dim dScores() As Double
    Dim inarray As Variant, NameList As Variant
    
    N = 20
    r = 4
 
    NameList = Range("MyNumbers").Value2
    lCombinations = GetCombinations(N, r)
    lPairs = GetCombinations(r, 2)
    ReDim dScores(1 To UBound(lCombinations), 1 To 1)
    ReDim lNumbers(1 To UBound(lCombinations), 1 To r)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, 1) = dScores(i, 1) + inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
        For j = 1 To r
            lNumbers(i, j) = NameList(1, lCombinations(i, j))
        Next j
    Next i
    
    'Dump results to check and sort, assuming columns Z:AD are free ..
    With Range("Z2").Resize(UBound(lCombinations))
        .Resize(, r).Value = lNumbers
        .Offset(, r).Value = dScores
        .Resize(, r + 1).Sort Key1:=.Columns(r + 1), Order1:=xlAscending
    End With

End Sub

 

[DonEB]

Once again... thank you. This is perfect!! Now I have to sit back and examine your code so I can better understand how it works. This is a tremendous time saver. Thanks for taking the time to assist me on this. It is much appreciated.

 

[DonEB]

I’ve been trying to understand your code with the hopes of trying to utilize similar code elsewhere or with the hopes of getting it to do a little more for me. While I am able to follow your logic, I don’t quite understand exactly how various functions work… thus I am unable to try and further enhance it.

And, since I asked you to summarize the player values (found inCommonData:E5:X24) into dScores, I lost the ability to perform the function described below because the 6 combination values that I once had is no longer being available. Of course, I thought I would be smart enough to take your code and subsequently enhance it to accomplish what I needed… but I have discovered that I am not that smart.

I don’t know if you are intrigued by what I’m trying to do, enjoy the challenge or simply like to help … but if you would like to try and take your code one step further… I would be excited to see how you go about resolving/simplifying my additional programming problems.

What I would like to try and incorporate is the rudimentary algorithm I created and use to identify and bring to the top the most desired matchups to be placed on the court. At the risk of being humiliated by the simplistic code I used, here is what I have been doing:

Notes:

1. This code is currently located in every cell from R7:R4851 and the results sorted in DESCENDING order to move the best candidates to the top of the list.
2. Also, I concatenated the functions (seen below) together in order to create a value upon which I was able to easily sort.
3. Finally, this code would FOLLOW the sorted value of dScores you previously provided. It is dScores that is used as a secondary sort to help break some ties in identifying best matchups.

=IF(OR(COUNTIF(H7:M7,$T$2)<1,COUNTIF(H7:M7,$T$3)>0),"N","Y")&COUNTIF(H7:M7,$T$2)&COUNTIF(H7:M7,$U$2)&IF(COUNTIF(H7:M7,$T$3)=0,6,6-COUNTIF(H7:M7,$T$3))&IF(COUNTIF(H7:M7,$T$4)=0,6,6-COUNTIF(H7:M7,$T$4))&IF(COUNTIF(H7:M7,$V$4)=0,6,6-COUNTIF(H7:M7,$V$4))

• Part I: IF(OR(COUNTIF(H7:M7,$T$2)<1,COUNTIF(H7:M7,$T$3)>0),"N","Y")
  • H7:M4851 = list of values for each player combination on each line. It is this combination that was summed up in dScores (I no longer have these values)
  • H7:M7 = first line of values used to be summed in dScores
  • $T$2 = Minimum Value found in CommonData:E5:X24
  • COUNTIF(H7:M7,$T$2)<1 .... if True then somebody played another player at least once
  • COUNTIF(H7:M7,$T$3)>0 .... if True then somebody played another player most frequently
  • "N","Y" .... “N” would cause combination to be push to bottom of list, “Y” would cause combination to be push to top of list
• Part II: COUNTIF(H7:M7,$T$2) –
  • $T$2 = Minimum Value found in CommonData:E5:X24
  • Determining how many players had the minimum value. The HIGHER the count the better
• Part III: COUNTIF(H7:M7,$U$2)
  • $U$2 = Second lowest Minimum Value found in CommonData:E5:X24
  • Determining how many players had the second lowest minimum value. Again, the higher the count the better
• Part IV: IF(COUNTIF(H7:M7,$T$3)=0,6,6-COUNTIF(H7:M7,$T$3))
  • $T$3 = Maximum Value found in CommonData:E5:X24
  • Determining how many players had the Maximum value. The FEWER players with the maximum value, the better
  • If count is 0 then all 6 have not played against one another before. Best case scenario is a "6"
  • If count is more than 0, then 6-COUNTIF(H7:M7,$T$3) is simply to identify how many players have played against one another.
• Part V: IF(COUNTIF(H7:M7,$T$4)=0,6,6-COUNTIF(H7:M7,$T$4))
  • $T$4 = Second highest Maximum Value found in CommonData:E5:X24
  • Same reasoning as above
• Part VI: IF(COUNTIF(H7:M7,$V$4)=0,6,6-COUNTIF(H7:M7,$V$4))
  • $T$5 = Third highest Maximum Value found in CommonData:E5:X24
  • Same reasoning as above

If you decide to give this a shot... it would be greatly appreciated. If you chose not to or don't have the time then I would respectfully request that, at the very least, you cause the six values that go into dScores to be inserted into the spreadsheet at H7:M7 and down to H4851:M4851. That would allow me to continue to use my existing code (with some modification)... which I would prefer not to use after seeing how efficient your code is.

Whatever you decide... I have appreciated all that you have done and have been quite impressed.

Thanks,
Don

 

[StephenCrump]

Try this code modification, which should produce results in a format similar to the screenshot below.

I haven't tried to understand your scoring and ranking formulae, but it looks like the gist of it is:

- Two combinations may have a similar total score.
- Combination A may consist of pairs who have played each other about the same number of times on average.
- Combination B consists of some pairs who have played each other often, and other pairs who have played each other only infrequently, i.e. a mix of high and low scores.

Combination A is to be preferred over Combination B.

So perhaps you could tiebreak A and B by simply considering the variance of each combination's scores?

And overall ranking could perhaps be decided by some sort of weighted average of total score and variance?

Sub Test()

    Dim lCombinations() As Long, lPairs() As Long, lNumbers() As Long, N As Long, r As Long, i As Long, j As Long, lOffset As Long
    Dim dScores() As Double
    Dim inarray As Variant, NameList As Variant
    
    N = 20
    r = 4
    lOffset = 7  'Col A --> Col H for scores
    lPairs = GetCombinations(r, 2)
    If UBound(lPairs) > lOffset Then
        MsgBox "You need a bigger offset!"
        Exit Sub
    End If
    
    NameList = Range("MyNumbers").Value2
    lCombinations = GetCombinations(N, r)
    ReDim dScores(1 To UBound(lCombinations), 1 To UBound(lPairs))
    ReDim lNumbers(1 To UBound(lCombinations), 1 To r)
    inarray = Sheets("CommonData").Range("E5:X23").Value2
    
    For i = 1 To UBound(lCombinations)
        For j = 1 To UBound(lPairs)
            dScores(i, j) = inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))
        Next j
        For j = 1 To r
            lNumbers(i, j) = NameList(1, lCombinations(i, j))
        Next j
    Next i
    
    With Worksheets([COLOR=#ff0000][B]"Results"[/B][/COLOR]).Range("A7").Resize(UBound(lCombinations))    [COLOR=#ff0000]'modify sheet name as appropriate[/COLOR]
        .Resize(, r).Value = lNumbers
        .Offset(, lOffset).Resize(, UBound(lPairs)).Value = dScores
        .Offset(, lOffset + UBound(lPairs)).FormulaR1C1 = "=SUM(RC[-" & UBound(lPairs) & "]:RC[-1])"
        .Resize(, lOffset + UBound(lPairs) + 1).Sort Key1:=.Columns(lOffset + UBound(lPairs) + 1), Order1:=xlAscending
    End With

End Sub

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
5	Combinations (sorted)							Scores
6	Player 1#	Player 2#	Player 3#	Player 4#				Pair 1	Pair 2	Pair 3	Pair 4	Pair 5	Pair 6	TOTAL
7	2	27	10	20				0.3	0.2	0.2	0.1	0.1	0.3	1.2
8	29	2	27	9				0.3	0.1	0.1	0.3	0.1	0.6	1.5
9	2	27	10	9				0.3	0.2	0.1	0.1	0.6	0.3	1.6
10	23	12	24	22				0.1	0.4	0.4	0.1	0.5	0.1	1.6
11	1	2	10	20				0.5	0.2	0.3	0.2	0.2	0.3	1.7
12	1	2	10	9				0.5	0.2	0.4	0.2	0.1	0.3	1.7
13	29	8	27	9				0.5	0.1	0.1	0.1	0.4	0.6	1.8
14	1	8	11	9				0.1	0.1	0.4	0.3	0.4	0.5	1.8
15	6	1	8	11				0.4	0.3	0.7	0.1	0.1	0.3	1.9
16	6	5	24	22				0.2	0.6	0.3	0.2	0.6	0.1	2.0
17	18	5	24	22				0.2	0.6	0.3	0.2	0.6	0.1	2.0
18	1	23	11	9				0.4	0.1	0.4	0.5	0.1	0.5	2.0
19	6	12	24	22				0.5	0.6	0.3	0.1	0.5	0.1	2.1
20	1	27	10	20				1.1	0.2	0.3	0.1	0.1	0.3	2.1
21	etc							etc
Results