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]

In other subroutines, I was setting cRange = Sheets("CommonData").Range("E5:X24").Value2. However, when I do this, then I get a "Run-Time Error '13'; Type Mismatch.

When you say setting, do you mean:

Dim cRange As Variant
'...
Set cRange = Sheets("CommonData").Range("E5:X24").Value2
'This will give you a type mismatch error.

You use Set for objects. So you could do something like:

Dim MyRange As Range
'...
Set MyRange = Sheets("CommonData").Range("E5:X24")
'...
'Do things with the MyRange object

But to pass the values of a range into a variant array, you need:

Dim cRange As Variant
'...
cRange = Sheets("CommonData").Range("E5:X24").Value2

If that's not the problem, perhaps you could post your code and confirm the line giving you the error message?

 

[DonEB]

When you say setting, do you mean:

Dim cRange As Variant
'...
Set cRange = Sheets("CommonData").Range("E5:X24").Value2
'This will give you a type mismatch error.

You use Set for objects. So you could do something like:

Dim MyRange As Range
'...
Set MyRange = Sheets("CommonData").Range("E5:X24")
'...
'Do things with the MyRange object

But to pass the values of a range into a variant array, you need:

Dim cRange As Variant
'...
cRange = Sheets("CommonData").Range("E5:X24").Value2

If that's not the problem, perhaps you could post your code and confirm the line giving you the error message?

Yes... I'm trying to pass the values of a range from one subroutine to another.
In a subroutine called TeamSelection(), I have set the following:

Dim cRange As Variant
cRange = Sheets("CommonData").Range("E5:X24").Value2

These occur just before calling the subroutine you created and I call PlayerCombo().

In PlayerCombo, I added the following code:

'''''''''''''''''''''''''''''''
' This is what inarray was originally set to in your code
'''''''''''''''''''''''''''''''
' inarray = Sheets("CommonData").Range("E5:X24").Value2

' I added the following within the subroutine just to validate that it was going to accept the variable.
' and it did.
'Dim cRange As Variant
'cRange = Sheets("CommonData").Range("E5:X24").Value2

' This is where I am attempting to set the variable inarray to my "range" This range will change as I move from one
' court to the next.
inarray = cRange

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))) '<===== This is the line that gets highlighted
Next j
For j = 1 To r
lNumbers(i, j) = NameList(1, lCombinations(i, j))
Next j
Next i


I note above which line gets highlighted and where I get the message saying Run-time error'13': Type mismatch.

Not sure what I'm missing...

 

[StephenCrump]

dScores(i, j) = inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2))) '<===== This is the line that gets highlighted

I get the message saying Run-time error'13': Type mismatch.

You should be able to debug the problem fairly easily.

When the code breaks, what is the inarray value? You should see it if you hover the cursor over the word: inarray?

Perhaps you have an error value, or a text value? Both will cause a type mismatch if you try to assign to a variable dScores declared as Double.

 

[DonEB]

I attempted to debug as you have taught me. When I hover over the word "inarray" it show a Type mismatch. I've uploaded a screen print to box for you to see. When I hover over any other portion of the code, I do not see any erroneous values being displayed. So... this is not telling me too much.

In the screen print, you will see (or not see) that cRange is being defined. I have defined that in the subroutine that is initiating the variable. If this is suppose to be done differently, please let me know.

Box

Any other thoughts?

 

[StephenCrump]

Based on that hover message, It looks like inarray isn't an array. Which implies that cRange also is not an array. Which means there is something wrong with the way cRange is being populated. Which I can't see.

Can you post all your code, thanks.

 

[DonEB]

I am providing the code from the two primary subroutines involved. The code you developed ( and I call PlayerCombo) and my subroutine called TeamSelection. I've saved them in a WORD document.... not sure what I was suppose to use.

Subroutines

Within TeamSelection I have defined cRange As Variant and then I initialize it with the Sheets reference. Later in that code I call Player Combo. I've highlighted all this in yellow for easy reference.

And you already have the error message I got when trying to run the macro which includes these subroutines.

But here's what really gets me... in the PlayerCombo sub routine, right above the inarray = cRange code, you will see that I have comment out and made reference to some "Testing" code. Before I tried to place the code in TeamSelection, I first placed it directly above the inarray = cRange code. And this worked successfully. Only when I placed the same code in the TeamSelection subroutine did I get the error message.
So... this is where I struggle to find the answer to the problem. Thanks for your assistance once again.

 

[StephenCrump]

In break mode, hover on this line:

inarray = cRange

and you'll see that both are Empty. Why is that?

You have declared cRange as Variant in Sub TeamSelection, so cRange is local to that Sub. So when you refer to cRange in Sub PlayerCombo, it is Empty.

I strongly recommend you always use Option Explicit in your coding (Google it to see why). If you had used Option Explicit, then VBA would have given you a Compile error: Variable not defined error message for cRange in Sub PlayerCombo. That would have saved you a lot of debug time!

 

[DonEB]

Yes... I can see how that would have saved me some time. Learning something new every day.

I read where the Option Explicit had to appear in a file before any other source code statements. So, I've placed it in Module 1 as the first item before I defined any Public variables. I have also defined a public variable in Module 1 called cRange as follows: Public cRange As Variant.

I also removed defining cRange as a local variable from the TeamSelection subroutine, however, I still set cRange = Sheets("CommonData").Range("E5:X24").Value2

When I run the program.... and stop at break point over the line inarray = cRange, continues to be empty.

 

[DonEB]

Not sure why that last message was sent 30 minutes ago I tried to updated it with this one but the time limit of 10 minutes got me. However, I do have a problem that involves the code you provided but have not been able to determine the cause.

Issue:

1. I was attempting to validate all the calculations that were performed by your code but, as you have noted, with so many numbers... it becomes nearly an impossible task.
2. As a result, I decided to simplify the testing and tried to apply all the same logic to just one court using 6 the SAME people.
3. As I initiate the process, I am able to successfully create assignments of 4 people to courts1 for weeks 1, 2, 3 and 4
4. Upon getting to week 5 something goes wrong.
5. I am able to determine that your code (sub PlayerCombo) is accessed
6. However, once completed, PlayerCombo does not write any information to my worksheet Courts1.
7. Using the hovering technique, I am able to determine that values are in fact present for Combinations and Namelist when hovering over "dScores(i, j) = inarray(lCombinations(i, lPairs(j, 1)), lCombinations(i, lPairs(j, 2)))" and "lNumbers(i, j) = NameList(1, lCombinations(i, j))"
8. So, it appears that the program gets into your program, but does not write the results to designated worksheet "Courts1". And, again, it worked successfully for the 4 weeks preceeding this one using the exact same data for input.

In the event you were inclined to take a look at it, I have decided to provide the following link to the entire worksheet. As you already know, I'm far less than a seasoned programmer thus my reluctance to share this in the past. I was just embarrassed by how archaic my attempt a coding might be versus how advanced and proficient your knowledge about coding is.

Here's the link in case you are interested. TennisDoublesQuarterlySchedule
Note: I discovered that you can't run a subroutine thru the spreadsheet while the TOGGLE BREAKPOINT is on. So, to be able to perform the tasks for different weeks you need to go to AllWeeks(B1) and change that number to the week you wish to run the program for. If you go in and look at that value, it is likely set to 5... meaning week 5. To make it run for week 4, just change that number to 4.

If not... if you have any thoughts or suggestions as to what the cause might be... I'll be all ears.

Thanks,
Don

 

[DonEB]

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

Stephen,
Because this was code you originally wrote in response to my inquiry, I felt it best to try and return to you for an answer.

First, the code work GREAT!!! Forever thankful!!

My question is, is it possible for the output to be written directly to an array instead of the worksheet? The code you developed is used up to four times when attempting to identify potential playing combinations for as many as 5 courts. Fortunately, once I get to the 5th court, the four remaining players don't need to go thru this process. They fill the 5th court by default. That being said, I'm attempting to make my coding more efficient and by writing directly to an array would seem to eliminate numerous reading and writing to various worksheets.

Currently, the following code is used in four different sub routines:
First, wsName will be either Courts1, Courts2, Courts3 or Courts4 and
Second, the arrays being written to will be either array_Chart10, array_Chart10a, array_Chart10b, array_Chart10c

Dim LastRowC1 As Long
LastRowC1 = Sheets(wsName).Range("C7:O4851").Find(What:="*", After:=Sheets(wsName).Range("C7:O4851").Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
array_Chart10 = ws3.Range("C7:P" & LastRowC1).Value

The use of "LastRowC1" is due to the number of players (i.e., N) used by the code actually range from 8 to 20 depending on how many players are participating and how many courts are required to be filled. I successfully have modified your code to account for those changing variables. Note: If there are a max of 20 players available for court 1 then there will be only 16 players available for court 2, and so on.

So, back to my question, is possible to incorporate the 3 lines I've included above into your code? I've stared at your code for hours and while I understand that it is the code on the bottom that ultimately writes the data to the worksheet, I have no clue as to how to modify that to accomplish what I am hoping to do.

Thanks for any feedback you might be willing to offer.

Don