Highest Permutation Value

[tazeo]

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	56.330	63.900	46.735	54.800	54.800	49.170	49.170	56.480	57.370	64.000	64.000	52.500	52.500
3	Player2	50.060	45.050	54.673	46.830	55.740	55.740	69.130	66.035	60.100	60.100	66.260	66.260	54.720	58.250	57.400	57.400	54.400	54.400
4	Player3	48.130	51.900	60.354	48.720	48.870	48.870	56.900	63.855	50.200	50.200	66.810	66.810	49.480	54.320	48.300	48.300	58.400	58.400
5	Player4	46.520	42.700	49.303	37.210	38.320	38.320	44.720	49.195	41.100	41.100	51.710	51.710	35.840	38.590	37.200	37.200	42.400	42.400
6	Player5	59.960	47.600	56.187	55.130	67.970	67.970	77.650	52.970	60.800	60.800	64.840	64.840	57.020	64.050	65.300	65.300	64.500	64.500
7	Player6	46.070	40.650	39.955	35.130	28.630	28.630	36.400	27.035	25.900	25.900	37.640	37.640	24.040	22.760	27.600	27.600	41.600	41.600
8	Player7	63.130	60.950	65.750	62.700	60.060	60.060	62.720	46.465	51.800	51.800	59.830	59.830	45.730	49.510	53.600	53.600	58.000	58.000
9	Player8	59.170	59.750	67.930	62.060	64.180	64.180	70.210	64.305	61.300	61.300	70.220	70.220	59.840	64.450	63.900	63.900	65.500	65.500
10	Player9	47.460	40.350	51.762	41.640	49.890	49.890	58.900	45.700	46.500	46.500	58.320	58.320	22.980	32.820	29.000	29.000	33.300	33.300
11	Player10	55.080	55.100	54.350	57.000	49.510	49.510	52.170	40.090	46.500	46.500	44.630	44.630	50.260	45.840	57.600	57.600	52.900	52.900
12	Player11	69.710	55.350	58.539	61.330	67.570	67.570	80.050	50.995	62.700	62.700	61.690	61.690	62.040	61.810	72.800	72.800	69.000	69.000
13	Player12	46.940	42.100	43.041	43.050	41.540	41.540	52.750	38.880	40.800	40.800	45.200	45.200	40.190	38.070	45.200	45.200	48.100	48.100
14	Player13	59.030	53.850	63.981	59.370	65.960	65.960	71.710	54.855	61.600	61.600	64.450	64.450	44.880	51.560	54.000	54.000	47.300	47.300
15	Player14	52.170	49.600	55.120	50.680	50.280	50.280	54.750	45.405	48.600	48.600	51.540	51.540	38.650	40.510	45.400	45.400	41.800	41.800
16	Player15	61.450	60.250	65.973	58.770	54.880	54.880	62.360	55.785	55.900	55.900	61.500	61.500	42.290	42.620	49.100	49.100	46.800	46.800
17	Player16	68.190	63.200	72.482	62.180	62.730	62.730	71.570	61.130	62.700	62.700	70.320	70.320	40.370	44.420	48.900	48.900	46.700	46.700
18	Player17	51.360	35.650	43.345	37.670	51.000	51.000	69.550	55.295	55.400	55.400	58.560	58.560	47.590	49.680	52.900	52.900	49.900	49.900
19	Player18	39.620	31.300	35.686	31.540	35.470	35.470	39.630	28.805	33.000	33.000	35.690	35.690	25.790	28.570	31.400	31.400	31.000	31.000
20	Player19	63.400	54.950	59.917	53.230	53.880	53.880	64.980	57.445	59.100	59.100	58.810	58.810	48.400	45.880	56.000	56.000	47.600	47.600
21	Player20	58.670	53.550	60.940	57.180	59.350	59.350	64.380	46.615	54.800	54.800	57.310	57.310	37.560	41.890	47.300	47.300	42.200	42.200
Sheet2

Can anyone help?

 

[PaddyD]

You'll need to tell us more about how the 'best' combination is to be determined - what happens, e.g., if the same player is best in 2 positions? & if the next best player is best in another position but the third placed player is so bad that it makes sense to use the second placed player & make do in the other position etc etc??

Is it always the case that the best team is the one with the highest possible scores?

 

[tazeo]

Okay I think this is what you asked:
A player can obviously only play in one position.
I want it so that the calculation works out the best combination of players. For example if you look at the scores for B2:D4 the best combination is actualy B2+C3+D4 even though it includes player 2's worst score.

With the same scores happening this will only happen with the #a positions (as the background calcs are complex) if that happens then they go into, say Pos 5, and the next selection goes into Pos 5a.

With 18 positions I would say that Yes it would be the best team has the highest score

 

[tazeo]

Anyone got some ideas for me?

 

[tazeo]

If it helps there are only 207 combinations

or should that be 1,216,451,004,088,320,000 - been a long day

 

[Andrew Fergus]

Hi

I thought I would give this one a nudge.....but this only tests a very limited number of scenarios - nothing near the number you proposed. This routine starts at position 1, finds the best player for that position, then checks position 2 and so forth. Then it holds onto that result, and starts again but this time starting from position 2 and tries the whole thing again round to position 1 and so forth.

I haven't tried this the other way, where you select a player and find the best position and so on but that would be an interesting exercise (although somewhat harder given there are more players than positions). With a bit of modification you could make it loop backwards through the positions to see if it can find a better combination. All told, I think there are too many combinations to test so an approximation (as I have done) might have to do.

Anyway, copy this code into a standard VBA module and give it a go. Set the constant values at the top of the code with the top left cell reference of the score range. This will output the results onto whatever sheet you specify (in the code) starting at cell A1 - just use a blank sheet.

Good luck!

Andrew

Option Explicit

Public Sub FindBestCombo()

On Error GoTo EH

Const InputSheet As String = "Sheet1" 'change this to your input sheet name
Const OutputSheet As String = "Sheet2" '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, _
    NextPosition As Long, _
    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

ReDim PlayerArray(NumPlayers, 1) 'holds the players names and a used indicator
ReDim PositionsArray(NumPositions) 'holds the position names
ReDim ResultsArray(NumPositions, 1) 'holds the player number for each position
'ResultsArray : 2nd dimension 0 = best, 1 = challenger
ReDim ScoreArray(NumPlayers, NumPositions) 'holds the scores

'Import the names, positions & scores
'Initialise the arrays
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) = .Cells(StartRow, StartCol + PositionLoop).Value
    Next PositionLoop
End With

For ScenarioLoop = 1 To NumPositions
    For tempVar = 1 To NumPositions
        ResultsArray(tempVar, 1) = 0 'clear the results array
    Next tempVar
    For PlayerLoop = 1 To NumPlayers
        PlayerArray(PlayerLoop, 1) = 0 'set all players to not used
    Next PlayerLoop
    For PositionLoop = ScenarioLoop To (ScenarioLoop + NumPositions - 1)
        If PositionLoop > NumPositions Then
            tempVar = PositionLoop - NumPositions
        Else
            tempVar = PositionLoop
        End If
        For PlayerLoop = 1 To NumPlayers
            If PlayerArray(PlayerLoop, 1) = 0 Then 'not used yet
                If ResultsArray(tempVar, 1) = 0 Then 'first free player
                    ResultsArray(tempVar, 1) = PlayerLoop
                    PlayerArray(PlayerLoop, 1) = 1
                Else
                    If ScoreArray(PlayerLoop, tempVar) > ScoreArray(ResultsArray(tempVar, 1), tempVar) Then
                        'better score
                        PlayerArray(ResultsArray(tempVar, 1), 1) = 0
                        PlayerArray(PlayerLoop, 1) = 1
                        ResultsArray(tempVar, 1) = PlayerLoop
                    ElseIf ScoreArray(PlayerLoop, tempVar) = ScoreArray(ResultsArray(tempVar, 1), tempVar) Then
                        'same score
                        If tempVar = NumPositions Then
                            NextPosition = 1
                        Else
                            NextPosition = tempVar + 1
                        End If
                        'Check the next position value
                        If ScoreArray(PlayerLoop, NextPosition) < ScoreArray(ResultsArray(tempVar, 1), NextPosition) Then
                            PlayerArray(ResultsArray(tempVar, 1), 1) = 0
                            PlayerArray(PlayerLoop, 1) = 1
                            ResultsArray(tempVar, 1) = PlayerLoop
                        End If
                    End If
                End If
            End If
        Next PlayerLoop
    Next PositionLoop
    If ScenarioLoop = 1 Then
        'Store this combination as the best
        For PositionLoop = 1 To NumPositions
            ResultsArray(PositionLoop, 0) = ResultsArray(PositionLoop, 1)
        Next PositionLoop
        ResultsArray(0, 0) = 0 'calculate total
        For PositionLoop = 1 To NumPositions
            ResultsArray(0, 0) = ResultsArray(0, 0) + ScoreArray(ResultsArray(PositionLoop, 0), PositionLoop)
        Next PositionLoop
    Else
        'Check the new combination versus the current best
        ResultsArray(0, 1) = 0
        For PositionLoop = 1 To NumPositions
            ResultsArray(0, 1) = ResultsArray(0, 1) + ScoreArray(ResultsArray(PositionLoop, 1), PositionLoop)
        Next PositionLoop
        If ResultsArray(0, 1) > ResultsArray(0, 0) Then
            'Found a better combination
            For PositionLoop = 1 To NumPositions
                ResultsArray(PositionLoop, 0) = ResultsArray(PositionLoop, 1)
            Next PositionLoop
            ResultsArray(0, 0) = ResultsArray(0, 1) 
        End If
    End If
Next ScenarioLoop

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

MsgBox "Finished!", vbInformation, "Done"

Exit Sub

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

End Sub

{late edit : fixed bug}

 

[erik.van.geit]

Hi,

Exceptionally I'll post code while I'm not sure at all anymore if this is correct. I'm sure it can generate the correct result, but the way to get there seems sooo loooong.

there are 18 columns with Positions & 20 Players
so that makes permutations of 18 out of 20
isn't that 1.200.000.000.000.000.000 possibilities?

suppose 5 rows 2 columns
you can generate all permutations
A 1, 2
B 1, 3
...
C 2, 1

and sum the values (cell relative to the range)
A = cell(1, 1) + cells(2, 2)
B= cell(1, 1) + cells(3/b], 2)
C= cell(2/b], 1) + cells(1/b], 2)

doesn't this prove that you need all permutations?

Option Explicit

Dim indexes As Variant
Dim Results As Worksheet
Dim maxComb As Variant
Dim maxVal As Long
Dim arr As Variant
Dim l As Long
Dim loops As Variant
Dim starttime As Double


'
' Myrna Larson,  July 25, 2000,  Microsoft.Public.Excel.Misc

Sub ListPermutationsOrCombinations()
Dim Rng As Range
Dim m As Long
Dim n As Long 'Double

'Application.EnableCancelKey = xlErrorHandler
'On Error GoTo skip


maxVal = 0
l = 0
Set Rng = Sheets(2).Range("B2:K21") 'Range("B2:S21")

arr = Rng.Value
n = UBound(arr, 1)  'Number of items
m = UBound(arr, 2)  'Items taken at a time


Set Results = Sheets(3)
Results.Columns("A:B").Clear

ReDim indexes(1 To n)
Dim i As Long
    For i = 1 To n
    indexes(i) = i
    Next i

loops = Application.WorksheetFunction.Permut(n, m)

    If loops > 10 ^ 7 Then
    MsgBox "Long process. Watch statusbar" & vbLf & _
    "Press Esc to stop. Current best will be displayed.", 64, "INFO"
    End If

starttime = Time
AddPermutation n, m

skip:
Application.StatusBar = False

    With Rng
    .Interior.ColorIndex = xlNone
        For i = 1 To m
        Rng(maxComb(i), i).Interior.ColorIndex = 6
        Next i
    End With


MsgBox "Max = " & maxVal, 64, "REPORT"

End Sub

Private Sub AddPermutation(Optional n As Long = 0, _
Optional m As Long = 0, _
Optional NextMember As Long = 0)

Static iPopSize As Long
Static iSetSize As Long
Static SetMembers() As Long
Static Used() As Long
Dim i As Long

    If n <> 0 Then
    iPopSize = n
    iSetSize = m
    ReDim SetMembers(1 To iSetSize) As Long
    ReDim Used(1 To iPopSize) As Long
    NextMember = 1
    End If

    For i = 1 To iPopSize
        If Used(i) = 0 Then
        SetMembers(NextMember) = i
            If NextMember <> iSetSize Then
            Used(i) = True
            AddPermutation , , NextMember + 1
            Used(i) = False
            Else
            operate SetMembers()
            End If
        End If

    Next i

    If NextMember = 1 Then
    Erase SetMembers
    Erase Used
    End If

End Sub


Private Sub operate(ItemsChosen() As Long)
Dim i As Long
Dim CombSum As Long
Dim sValue As String
Dim cntLoops As String
Dim endtime As String

    For i = 1 To UBound(ItemsChosen)
    CombSum = CombSum + arr(ItemsChosen(i), i)
    Next i

    If CombSum > maxVal Then
    maxVal = CombSum
    maxComb = ItemsChosen
    End If

    l = l + 1
    If l Mod 333333 = 0 Then
    cntLoops = "Done: " & Format(Round(l / loops, 4), "0.00%")
    'end time ??? perhaps not correct ... or does it really take ages ???
    'endtime = " Endresult " & Format(Now + (Time - starttime) / l * loops, "\Date: MMDDYYYY \Hour: HH:MM AM/PM")
    Application.StatusBar = cntLoops & " Current Maximum " & maxVal & endtime
    End If
        
End Sub

kind regards,
Erik

 

[tazeo]

@Andrew
That works well and I can even see how it works Although it doesn't exhaust all the permutations, it is certainly better than the mark one eyeball method I have been using

@Erik
I'm not sure how to get this going, I reckognise that a simple cut and past won't work, but thats about as far as my experience gets

And thanks to you both

 

[Andrew Fergus]

Hi

I fixed a bug in the code earlier today so you may want to check you have the correct version. Did you get 1073.8?

Given the number of permutations (and Erik's experiences with the long loops) I purposely didn't try to test all of the possible combinations. I simply coded a method a person might use when trying to manually solve the problem.

As far as I can see this thread is a long way from being resolved - I believe an alternative solution is being played with as we post.....but we will wait and see what develops.

Andrew

 

[tazeo]

Hi Andrew
Yep I used you updated code and it works as you have explained.

Again thanks to both you and Erik, and whom ever may be working in the wings... :wink: