Highest Permutation Value

tazeo · May 4, 2007

I am think what I want to do is in the realms of the GURU excel user

and well beyond what I can do.

This is for an online sports management game I play. Basically I have calculated each players skills in each position, and I need to find the best combination of the players on the field to give me the best team.

I have a table as below, and I need to find a solution that gives me what the best combination will be.

OTB1.xls

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

1

Name

Pos1

Pos2

Pos3

Pos4

Pos5

Pos5a

Pos6

Pos7

Pos8

Pos8a

Pos9

Pos9a

Pos10

Pos11

Pos12

Pos12a

Pos13

Pos13a

2

Player1

49.200

39.650

44.801

46.890

56.330

63.900

46.735

54.800

49.170

56.480

57.370

64.000

52.500

3

Player2

50.060

45.050

54.673

46.830

55.740

69.130

66.035

60.100

66.260

54.720

58.250

57.400

54.400

4

Player3

48.130

51.900

60.354

48.720

48.870

56.900

63.855

50.200

66.810

49.480

54.320

48.300

58.400

5

Player4

46.520

42.700

49.303

37.210

38.320

44.720

49.195

41.100

51.710

35.840

38.590

37.200

42.400

6

Player5

59.960

47.600

56.187

55.130

67.970

77.650

52.970

60.800

64.840

57.020

64.050

65.300

64.500

7

Player6

46.070

40.650

39.955

35.130

28.630

36.400

27.035

25.900

37.640

24.040

22.760

27.600

41.600

8

Player7

63.130

60.950

65.750

62.700

60.060

62.720

46.465

51.800

59.830

45.730

49.510

53.600

58.000

9

Player8

59.170

59.750

67.930

62.060

64.180

70.210

64.305

61.300

70.220

59.840

64.450

63.900

65.500

10

Player9

47.460

40.350

51.762

41.640

49.890

58.900

45.700

46.500

58.320

22.980

32.820

29.000

33.300

11

Player10

55.080

55.100

54.350

57.000

49.510

52.170

40.090

46.500

44.630

50.260

45.840

57.600

52.900

12

Player11

69.710

55.350

58.539

61.330

67.570

80.050

50.995

62.700

61.690

62.040

61.810

72.800

69.000

13

Player12

46.940

42.100

43.041

43.050

41.540

52.750

38.880

40.800

45.200

40.190

38.070

45.200

48.100

14

Player13

59.030

53.850

63.981

59.370

65.960

71.710

54.855

61.600

64.450

44.880

51.560

54.000

47.300

15

Player14

52.170

49.600

55.120

50.680

50.280

54.750

45.405

48.600

51.540

38.650

40.510

45.400

41.800

16

Player15

61.450

60.250

65.973

58.770

54.880

62.360

55.785

55.900

61.500

42.290

42.620

49.100

46.800

17

Player16

68.190

63.200

72.482

62.180

62.730

71.570

61.130

62.700

70.320

40.370

44.420

48.900

46.700

18

Player17

51.360

35.650

43.345

37.670

51.000

69.550

55.295

55.400

58.560

47.590

49.680

52.900

49.900

19

Player18

39.620

31.300

35.686

31.540

35.470

39.630

28.805

33.000

35.690

25.790

28.570

31.400

31.000

20

Player19

63.400

54.950

59.917

53.230

53.880

64.980

57.445

59.100

58.810

48.400

45.880

56.000

47.600

21

Player20

58.670

53.550

60.940

57.180

59.350

64.380

46.615

54.800

57.310

37.560

41.890

47.300

42.200

Sheet2

Can anyone help?

Andrew Fergus · May 25, 2007

Hi

How about this revised code - same deal as before, but it gives a higher total team score.

Code:

Public Sub FindAnotherCombo()

On Error GoTo EH

Const InputSheet As String = "Sheet1" 'change this to your input sheet name
Const OutputSheet As String = "Sheet3" 'change this to your output sheet name
Const StartRow As Long = "1" 'set this to the first row number (including the headings)
Const StartCol As Long = "1" 'set this to the first column number, e.g. "A" = 1, "B" = 2

Dim NumPlayers As Long, _
    NumPositions As Long, _
    BestPosition As Long, _
    BestPlayer As Long, _
    CurrentTotal As Double, _
    NewTotal As Double, _
    tempVar As Long
Dim ScenarioLoop As Long, _
    PositionLoop As Long, _
    PlayerLoop As Long
Dim PlayerArray() As String, _
    PositionsArray() As String, _
    ScoreArray() As Double, _
    ResultsArray() As Long

NumPlayers = Sheets(InputSheet).Cells(StartRow, StartCol).End(xlDown).Row - 1
NumPositions = Sheets(InputSheet).Cells(StartRow, StartCol).End(xlToRight).Column - 1

'Initialise the arrays
ReDim PlayerArray(NumPlayers, 1) 'holds the players names & used indicator
ReDim PositionsArray(NumPositions, 1) 'holds the position names and a used indicator
ReDim ResultsArray(NumPositions, 1) 'holds the best position and player numbers
ReDim ScoreArray(NumPlayers, NumPositions) 'hold the players scores

'Import the names, positions & scores
With Sheets(InputSheet)
    For PlayerLoop = 1 To NumPlayers
        PlayerArray(PlayerLoop, 0) = _
            .Cells(StartRow + PlayerLoop, StartCol).Value
        PlayerArray(PlayerLoop, 1) = 0 'not used indicator
        For PositionLoop = 1 To NumPositions
            ScoreArray(PlayerLoop, PositionLoop) = _
                .Cells(StartRow + PlayerLoop, StartCol + PositionLoop).Value
        Next PositionLoop
    Next PlayerLoop
    For PositionLoop = 1 To NumPositions
        PositionsArray(PositionLoop, 0) = _
            .Cells(StartRow, StartCol + PositionLoop).Value
        PositionsArray(PositionLoop, 1) = 0 'clear the used field for the positions
        ResultsArray(PositionLoop, 0) = 0 'clear the results array
        ResultsArray(PositionLoop, 1) = 0
    Next PositionLoop
End With

'Pick the highest values first
ScoreArray(0, 0) = 0
For ScenarioLoop = 1 To NumPositions
    BestPosition = 0
    BestPlayer = 0
    For PositionLoop = 1 To NumPositions
        If PositionsArray(PositionLoop, 1) = 0 Then
            For PlayerLoop = 1 To NumPlayers
                If PlayerArray(PlayerLoop, 1) = 0 Then
                    If ScoreArray(PlayerLoop, PositionLoop) > _
                        ScoreArray(BestPlayer, BestPosition) Then
                            PlayerArray(BestPlayer, 1) = 0
                            PositionsArray(BestPosition, 1) = 0
                            BestPlayer = PlayerLoop
                            BestPosition = PositionLoop
                            PlayerArray(PlayerLoop, 1) = 1
                            PositionsArray(PositionLoop, 1) = 1
                    End If
                End If
            Next PlayerLoop
        End If
    Next PositionLoop
    ResultsArray(ScenarioLoop, 0) = BestPlayer
    ResultsArray(ScenarioLoop, 1) = BestPosition
Next ScenarioLoop

'Compare each pair to see if there is a swap that will result in a higher score
tempVar = 1
Do While tempVar <> 0
    tempVar = 0
    For ScenarioLoop = 1 To NumPositions
        For PlayerLoop = 1 To NumPositions
            CurrentTotal = ScoreArray(ResultsArray(ScenarioLoop, 0), ResultsArray(ScenarioLoop, 1)) _
                + ScoreArray(ResultsArray(PlayerLoop, 0), ResultsArray(PlayerLoop, 1))
            NewTotal = ScoreArray(ResultsArray(ScenarioLoop, 0), ResultsArray(PlayerLoop, 1)) _
                + ScoreArray(ResultsArray(PlayerLoop, 0), ResultsArray(ScenarioLoop, 1))
            If NewTotal > CurrentTotal Then
                tempVar = tempVar + 1
                BestPosition = ResultsArray(ScenarioLoop, 1)
                ResultsArray(ScenarioLoop, 1) = ResultsArray(PlayerLoop, 1)
                ResultsArray(PlayerLoop, 1) = BestPosition
            End If
        Next PlayerLoop
    Next ScenarioLoop
Loop

'Show the results
With Sheets(OutputSheet)
    For ScenarioLoop = 1 To NumPositions
        .Cells(ScenarioLoop, 1) = PositionsArray(ResultsArray(ScenarioLoop, 1), 0)
        .Cells(ScenarioLoop, 2) = PlayerArray(ResultsArray(ScenarioLoop, 0), 0)
        .Cells(ScenarioLoop, 3) = ScoreArray(ResultsArray(ScenarioLoop, 0), ResultsArray(ScenarioLoop, 1))
    Next ScenarioLoop
End With

MsgBox "Finished!", vbInformation, "Done..."

Exit Sub

EH:
    MsgBox Err.Description, vbCritical, "Error# " & Err.Number

End Sub

Andrew

Andrew Fergus · May 25, 2007

Or try this technique:

Instead of picking out the highest values and then trying to find higher value pairs (which is what the previous version does), this starts with the position that has the lowest possible high score, populates that first and repeats this process for the second to lowest possible high score and so on. Then it sees if it can swap pairs to come up with a better result.

It's not too bad considering we aren't testing all of the possible permutations......

Andrew

Code:

Public Sub FindComboNew()

On Error GoTo EH

Const InputSheet As String = "Sheet1" 'change this to your input sheet name
Const OutputSheet As String = "Sheet4" 'change this to your output sheet name
Const StartRow As Long = "1" 'set this to the first row number (including the headings)
Const StartCol As Long = "1" 'set this to the first column number, e.g. "A" = 1, "B" = 2

Dim NumPlayers As Long, _
    NumPositions As Long, _
    BestPosition As Long, _
    BestPlayer As Long, _
    tempVar As Long, _
    CurrentTotal As Double, _
    NewTotal As Double
Dim ScenarioLoop As Long, _
    PositionLoop As Long, _
    PlayerLoop As Long
Dim PlayerArray() As String, _
    PositionsArray() As String, _
    ScoreArray() As Double, _
    ResultsArray() As Long

NumPlayers = Sheets(InputSheet).Cells(StartRow, StartCol).End(xlDown).Row - 1
NumPositions = Sheets(InputSheet).Cells(StartRow, StartCol).End(xlToRight).Column - 1

'Initialise the arrays
ReDim PlayerArray(NumPlayers, 1) 'holds the players names and a used indicator
ReDim PositionsArray(NumPositions, 3) 'holds the position names, used indicator, hi-score and ranking
ReDim ResultsArray(NumPositions, 1) 'holds the best position and player numbers
ReDim ScoreArray(NumPlayers, NumPositions) 'hold the players scores

'Import the names, positions & scores
With Sheets(InputSheet)
    For PositionLoop = 1 To NumPositions
        PositionsArray(PositionLoop, 0) = .Cells(StartRow, StartCol + PositionLoop).Value
        PositionsArray(PositionLoop, 1) = 0 'clear the used field for the positions
        PositionsArray(PositionLoop, 2) = 0 'clear the ranking field
        PositionsArray(PositionLoop, 3) = 0 'clear the hi-score field
        ResultsArray(PositionLoop, 0) = 0 'clear the results array
        ResultsArray(PositionLoop, 1) = 0
    Next PositionLoop
    For PlayerLoop = 1 To NumPlayers
        PlayerArray(PlayerLoop, 0) = .Cells(StartRow + PlayerLoop, StartCol).Value
        PlayerArray(PlayerLoop, 1) = 0 'used indicator
        For PositionLoop = 1 To NumPositions
            ScoreArray(PlayerLoop, PositionLoop) = _
            .Cells(StartRow + PlayerLoop, StartCol + PositionLoop).Value
                If ScoreArray(PlayerLoop, PositionLoop) > _
                PositionsArray(PositionLoop, 3) Then
                    PositionsArray(PositionLoop, 3) = ScoreArray(PlayerLoop, PositionLoop)
            End If
        Next PositionLoop
    Next PlayerLoop
End With

For ScenarioLoop = 1 To NumPositions
    For PositionLoop = 1 To NumPositions
        If PositionsArray(PositionLoop, 3) > PositionsArray(ScenarioLoop, 3) Then
           PositionsArray(ScenarioLoop, 2) = PositionsArray(ScenarioLoop, 2) + 1
        ElseIf PositionsArray(PositionLoop, 3) = PositionsArray(ScenarioLoop, 3) Then
            If PositionLoop > ScenarioLoop Then
               PositionsArray(ScenarioLoop, 2) = PositionsArray(ScenarioLoop, 2) + 1
            End If
        End If
    Next PositionLoop
    Debug.Print PositionsArray(ScenarioLoop, 2) & " : " & PositionsArray(ScenarioLoop, 3)
Next ScenarioLoop

ScoreArray(0, 0) = 0
For ScenarioLoop = NumPositions To 1 Step -1
    BestPosition = 0
    BestPlayer = 0
    For PositionLoop = 1 To NumPositions
        If PositionsArray(PositionLoop, 2) = ScenarioLoop - 1 Then
            For PlayerLoop = 1 To NumPlayers
                If PlayerArray(PlayerLoop, 1) = 0 Then
                    If ScoreArray(PlayerLoop, PositionLoop) > _
                    ScoreArray(BestPlayer, BestPosition) Then
                        PlayerArray(BestPlayer, 1) = 0
                        BestPlayer = PlayerLoop
                        BestPosition = PositionLoop
                        PlayerArray(PlayerLoop, 1) = 1
                    End If
                End If
            Next PlayerLoop
        End If
    Next PositionLoop
    ResultsArray(ScenarioLoop, 0) = BestPlayer
    ResultsArray(ScenarioLoop, 1) = BestPosition
Next ScenarioLoop

'Compare each pair to see if there is a swap that will result in a higher score
tempVar = 1
Do While tempVar <> 0
    tempVar = 0
    For ScenarioLoop = 1 To NumPositions
        For PlayerLoop = 1 To NumPositions
            CurrentTotal = ScoreArray(ResultsArray(ScenarioLoop, 0), _
                                ResultsArray(ScenarioLoop, 1)) _
                            + ScoreArray(ResultsArray(PlayerLoop, 0), _
                                ResultsArray(PlayerLoop, 1))
            NewTotal = ScoreArray(ResultsArray(ScenarioLoop, 0), _
                            ResultsArray(PlayerLoop, 1)) _
                        + ScoreArray(ResultsArray(PlayerLoop, 0), _
                            ResultsArray(ScenarioLoop, 1))
            If NewTotal > CurrentTotal Then
                tempVar = tempVar + 1
                BestPosition = ResultsArray(ScenarioLoop, 1)
                ResultsArray(ScenarioLoop, 1) = ResultsArray(PlayerLoop, 1)
                ResultsArray(PlayerLoop, 1) = BestPosition
            End If
        Next PlayerLoop
    Next ScenarioLoop
    Debug.Print "total swaps = " & tempVar
Loop

'Show the results
With Sheets(OutputSheet)
    For ScenarioLoop = 1 To NumPositions
        .Cells(ScenarioLoop, 1) = PositionsArray(ResultsArray(ScenarioLoop, 1), 0)
        .Cells(ScenarioLoop, 2) = PlayerArray(ResultsArray(ScenarioLoop, 0), 0)
        .Cells(ScenarioLoop, 3) = ScoreArray(ResultsArray(ScenarioLoop, 0), ResultsArray(ScenarioLoop, 1))
    Next ScenarioLoop
End With

MsgBox "Processing complete...", vbInformation, "Finished!"

Exit Sub

EH:
    MsgBox Err.Description, vbCritical, "Error# " & Err.Number

End Sub

erik.van.geit · May 25, 2007

Andrew, you did also have some sparetime, isn't it? :D

tazeo,
It would be great to check the permutation count. When it's too high - you decide what number - the code would take Andrews system which is "very close", else a "correct" system like mine.

SydneyGeek · May 25, 2007

I'll chuck in another approach. This one does most of the heavy lifting with some worksheet formulas, and leaves the working on the sheet. (It can be removed if you want).

Code...

Code:

Sub FindBestTeam()
Dim Rw As Long, _
    Col As Long, _
    i As Long, _
    j As Long
Dim rngRef As Range, _
    rngWhichCol As Range, _
    rngMaxVal As Range, _
    rngWhichPlayer As Range, _
    rngOutput As Range
Const LOW_RANK = 1000

Application.Calculation = xlCalculationManual
'write MAX formula to bottom of table
Rw = Range("A1").CurrentRegion.Rows.Count
Col = Range("A1").CurrentRegion.Columns.Count
Cells(Rw + 1, 2).Resize(1, Col - 1).FormulaR1C1 = _
    "=MAX(R[-" & Rw & "]C:R[-1]C)"

'copy table down, 3 rows below original, and determine reference position
Range("A1").CurrentRegion.Copy _
    Destination:=Cells(Rw + 3, 1)
Set rngRef = Cells(Rw + 3, 1)
Set rngWhichCol = rngRef.Offset(Rw + 3, 0)
Set rngMaxVal = rngRef.Offset(Rw + 4, 0)
Set rngWhichPlayer = rngRef.Offset(Rw + 5, 0)
Set rngOutput = rngRef.Offset(Rw + 10, 0)

'write reference formulas and headings
rngRef.Offset(Rw + 1, 1).Resize(1, Col - 1).FormulaR1C1 = _
    "=LARGE(R[-21]C:R[-2]C,2)"
rngRef.Offset(Rw + 2, 1).Resize(1, Col - 1).FormulaR1C1 = _
    "=R[-2]C-R[-1]C"
rngRef.Offset(Rw + 3, 1).Resize(1, Col - 1).FormulaR1C1 = _
    "=RANK(R[-1]C,R[-1]C2:R[-1]C19,0)"
rngWhichCol.FormulaArray = "=MATCH(MIN(RC[1]:RC[18]),RC[1]:RC[18],0)"
rngWhichCol.Offset(1, 0).FormulaR1C1 = "=INDEX(R[-4]C[1]:R[-4]C[18],1,R[-1]C)"
rngWhichCol.Offset(2, 0).FormulaR1C1 = "=MATCH(R[-1]C,OFFSET(R[-" & Rw + 4 & "]C:R[-6]C,0,R[-2]C),0)"
rngOutput = "Position"
rngOutput.Offset(1, 0) = "Player"
rngOutput.Offset(2, 0) = "Score"

'loop through each position, prioritising on the position that has the most impact on the next choice.
For i = 1 To Col
    rngOutput.Offset(0, rngWhichCol.Value) = rngRef.Offset(0, rngWhichCol.Value)
    rngOutput.Offset(1, rngWhichCol.Value) = rngRef.Offset(rngWhichPlayer.Value, 0)
    rngOutput.Offset(2, rngWhichCol.Value) = rngRef.Offset(rngWhichPlayer.Value, rngWhichCol.Value)
    For j = 1 To Col - 1
        If j <> rngWhichCol.Value Then rngRef.Offset(rngWhichPlayer.Value, j) = 0
    Next j
    rngWhichCol.Offset(0, rngWhichCol.Value) = LOW_RANK
    ActiveSheet.Calculate
Next i

End Sub

Result using this approach: 1087.067
Not as good as Andrew's but another way to look at the problem...

Denis

tazeo · May 25, 2007

Thanks to you all, you have been really helpful. I just wish I could follow the coding more so I could understand it as well as appreciated your help.

I think Erik might be right about running all the permutations but that is a number to the power of 18, which is huge, even if it considers just the top 10 for each position it would be to the power of 14

I'd like to see how close a complete run is to the ones Andrew has come up with, if the margin is close enough, it might just be easier to run with that.

Again Thank you to you all.

tazeo · May 25, 2007

Erik
just after your post of your code I posted a question on how to use your code as a straight cut and paste doesn't work. It is giving me an error something about not having info outside of subs.

Can you let me know how to use your code?

erik.van.geit · May 26, 2007

Erik
just after your post of your code I posted a question on how to use your code as a straight cut and paste doesn't work. It is giving me an error something about not having info outside of subs.

Can you let me know how to use your code?

Oh, I didn't respond anymore since you seemed to have used Andrews code before I went back here.
It is code like any other code. Should start without errors. What did you do to make it run? Anyway it would run for years.

tazeo · May 26, 2007

Thanks Erik
I was interested in seeing how much better the result could get if all permutations were done.

BTW what is the best way to get better at VB?

erik.van.geit · May 26, 2007

Thanks Erik
I was interested in seeing how much better the result could get if all permutations were done.

BTW what is the best way to get better at VB?

You can test it on smaller ranges. To my sense 10 rows x 8 columns is reasonable.

Range("B2:H8") < 1 sec
Range("B2:H12") < 12 sec
Range("B2:I12") < 1 minute
Range("B2:I15") about 20 minutes

you can enable these lines

Code:

Application.EnableCancelKey = xlErrorHandler
On Error GoTo skip

to exit the code using "escape"

the current maximum will be colored

best regards,
Erik

Highest Permutation Value

tazeo

Board Regular

Andrew Fergus

MrExcel MVP

Excel Facts

Andrew Fergus

MrExcel MVP

erik.van.geit

MrExcel MVP

SydneyGeek

MrExcel MVP

tazeo

Board Regular

tazeo

Board Regular

erik.van.geit

MrExcel MVP

tazeo

Board Regular

erik.van.geit

MrExcel MVP

Similar threads

Forum statistics

Share this page

Highest Permutation Value

Board Regular

MrExcel MVP

Excel Facts

MrExcel MVP

MrExcel MVP

MrExcel MVP

Board Regular

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock