Need VBA Code for "permutations" and probablities

TheRinger · Jul 31, 2016

Here is what i have and have wrote these formulas all the way to the 9th horse winning. Yea 3078 combinations and don't look forward to doing the remaining combinations. I'm Hoping someone could help me by sharing some code that would calculate this for me without writing another 3762 formulas. I hope my table below explains it well enough. I enter ratings on each entrant and have formulas that give me each entrants probability. From these probabilities the formulas shown Known as the harville formula gives me the permutations(Trifecta) winning probability.

<tbody>
[TD="class: xl94"]Betting Number[/TD]
[TD="class: xl87"]My Rating[/TD]
[TD="class: xl87"]My Win Odds[/TD]
[TD="class: xl87"]My Win Probability[/TD]
[TD="class: xl95, width: 78"]Permutation
Combination[/TD]
[TD="class: xl96, width: 81"]Permutation Probability[/TD]
[TD="class: xl91, width: 194"]Formula used for each Permutation[/TD]

[TD="class: xl66"]1[/TD]
[TD="class: xl83"]90[/TD]
[TD="class: xl68"]3.91[/TD]
[TD="class: xl69"]20.37%[/TD]
[TD="class: xl85"]1-2-3[/TD]
[TD="class: xl86"]0.008%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$4*($E$5/(1-$E$4))*(E6/(1-($E$4+$E$5)))),($E$4*($E$5/(1-$E$4))*(E6/(1-($E$4+$E$5)))),"-")[/TD]

[TD="class: xl65"]2[/TD]
[TD="class: xl82"]65[/TD]
[TD="class: xl68"]72.25[/TD]
[TD="class: xl81"]1.37%[/TD]
[TD="class: xl85"]1-2-4[/TD]
[TD="class: xl86"]0.056%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$4*($E$5/(1-$E$4))*(E7/(1-($E$4+$E$5)))),($E$4*($E$5/(1-$E$4))*(E7/(1-($E$4+$E$5)))),"-")[/TD]

[TD="class: xl71"]3[/TD]
[TD="class: xl83"]67[/TD]
[TD="class: xl68"]57.21[/TD]
[TD="class: xl69"]1.72%[/TD]
[TD="class: xl85"]1-2-5[/TD]
[TD="class: xl86"]0.030%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$4*($E$5/(1-$E$4))*(E8/(1-($E$4+$E$5)))),($E$4*($E$5/(1-$E$4))*(E7/(1-($E$4+$E$5)))),"-")[/TD]

[TD="class: xl70"]4[/TD]
[TD="class: xl82"]85[/TD]
[TD="class: xl68"]7.01[/TD]
[TD="class: xl81"]12.49%[/TD]
[TD="class: xl84"]1-2-ETC[/TD]
[TD="class: xl88"]ETC[/TD]
[TD="class: xl92"]ETC[/TD]

[TD="class: xl73"]5[/TD]
[TD="class: xl83"]79[/TD]
[TD="class: xl68"]14.11[/TD]
[TD="class: xl69"]6.62%[/TD]
[TD="class: xl85"]2-1-3[/TD]
[TD="class: xl86"]0.006%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$5*($E$4/(1-$E$5))*(E6/(1-($E$5+$E$4)))),($E$5*($E$4/(1-$E$5))*(E6/(1-($E$5+$E$4)))),"-")[/TD]

[TD="class: xl72"]6[/TD]
[TD="class: xl82"]67[/TD]
[TD="class: xl68"]57.21[/TD]
[TD="class: xl81"]1.72%[/TD]
[TD="class: xl85"]2-1-4[/TD]
[TD="class: xl86"]0.045%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$5*($E$4/(1-$E$5))*(E7/(1-($E$5+$E$4)))),($E$5*($E$4/(1-$E$5))*(E6/(1-($E$5+$E$4)))),"-")[/TD]

[TD="class: xl75"]7[/TD]
[TD="class: xl83"]88[/TD]
[TD="class: xl68"]4.94[/TD]
[TD="class: xl69"]16.84%[/TD]
[TD="class: xl85"]2-1-5[/TD]
[TD="class: xl86"]0.024%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$5*($E$4/(1-$E$5))*(E8/(1-($E$5+$E$4)))),($E$5*($E$4/(1-$E$5))*(E6/(1-($E$5+$E$4)))),"-")[/TD]

[TD="class: xl74"]8[/TD]
[TD="class: xl82"]83[/TD]
[TD="class: xl68"]8.85[/TD]
[TD="class: xl81"]10.15%[/TD]
[TD="class: xl84"]2-1-ETC[/TD]
[TD="class: xl88"]ETC[/TD]
[TD="class: xl92"]ETC[/TD]

[TD="class: xl77"]9[/TD]
[TD="class: xl83"]80[/TD]
[TD="class: xl68"]12.56[/TD]
[TD="class: xl69"]7.38%[/TD]
[TD="class: xl85"]3-1-2[/TD]
[TD="class: xl86"]0.006%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$6*($E$4/(1-$E$6))*(E5/(1-($E$6+$E$4)))),($E$6*($E$4/(1-$E$6))*(E5/(1-($E$6+$E$4)))),"-")[/TD]

[TD="class: xl76"]10[/TD]
[TD="class: xl82"]77[/TD]
[TD="class: xl68"]17.82[/TD]
[TD="class: xl81"]5.31%[/TD]
[TD="class: xl85"]3-1-4[/TD]
[TD="class: xl86"]0.057%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$6*($E$4/(1-$E$6))*(E7/(1-($E$6+$E$4)))),($E$6*($E$4/(1-$E$6))*(E5/(1-($E$6+$E$4)))),"-")[/TD]

[TD="class: xl79"]11[/TD]
[TD="class: xl83"]73[/TD]
[TD="class: xl68"]28.41[/TD]
[TD="class: xl69"]3.40%[/TD]
[TD="class: xl85"]3-1-5[/TD]
[TD="class: xl86"]0.030%[/TD]
[TD="class: xl92"]IF(ISNUMBER($E$6*($E$4/(1-$E$6))*(E8/(1-($E$6+$E$4)))),($E$6*($E$4/(1-$E$6))*(E5/(1-($E$6+$E$4)))),"-")[/TD]

[TD="class: xl78"]12[/TD]
[TD="class: xl82"]85[/TD]
[TD="class: xl68"]7.01[/TD]
[TD="class: xl81"]12.49%[/TD]
[TD="class: xl93"]20-19-18[/TD]
[TD="class: xl90"]ETC[/TD]

</tbody>

Meesam_ali · Aug 4, 2016

Ok apologies for one mistake that there is NO NEED of creating another sheet at all. You can use same sheet called "input" or any name you like (and change same in code). The following table is my result after I ran the code after table below.

Code:

Sub HorseRace()
Dim rng1 As Range, rCell As Range, lastRow1 As Long, lastrRow2 As Long
Dim winner As String, placer As String, shower As String, rngHorse As Range
Dim rngFull As Range
Dim w1 As String, p1 As String, s1 As String
Dim w2 As Range, p2 As Range, s2 As Range
Dim w3 As Single, p3 As Single, s3 As Single


lastRow = ThisWorkbook.Sheets("input").Range("f4").End(xlDown).Row
Set rngHorse = ThisWorkbook.Sheets("input").Range("b4:b" & lastRow)
Set rng1 = ThisWorkbook.Sheets("input").Range("f4:f" & lastRow)
Set rngFull = ThisWorkbook.Sheets("input").Range("b4:h" & lastRow)
count = 0


For Each rCell In rng1
    'Parse the cell to get three components
    winner = makeParts(rCell.Value)(0)
    placer = makeParts(rCell.Value)(1)
    shower = makeParts(rCell.Value)(2)
    
    'check the probabilities using find function
        Set w2 = rngHorse.Find(winner, LookIn:=xlValues, lookat:=xlWhole)
            w1 = w2.Address
            w3 = Range(Replace(w1, "$", "")).Offset(0, 1).Value
        Set p2 = rngHorse.Find(placer, LookIn:=xlValues, lookat:=xlWhole)
            p1 = p2.Address
            p3 = Range(Replace(p1, "$", "")).Offset(0, 1).Value
        Set s2 = rngHorse.Find(shower, LookIn:=xlValues, lookat:=xlWhole)
            s1 = s2.Address
            s3 = Range(Replace(s1, "$", "")).Offset(0, 1).Value
    
    'Formula as given by Ringer to be placed in 3 columns offset
    rCell.Offset(0, 1).Value = w3 * ((p3 / (1 - w3))) * (s3 / (1 - (w3 + p3)))
    count = count + 1
Next rCell




End Sub


Function makeParts(valInput As String) As Variant()
  
  Dim Parts() As String
  Dim r1 As Integer, r2 As Integer, r3 As Integer
  
  On Error Resume Next
  Parts = Split(valInput, "-")
  r1 = Parts(0)
  r2 = Parts(1)
  r3 = Parts(2)
  makeParts = Array(r1, r2, r3)
  
End Function

TheRinger · Aug 4, 2016

Thank you again for taking the time to help me with this project.
You got it, the code is working properly. Is there any way to code it to output the Trifecta combo's along with the Trifecta win%? I have some code that will generate the all the combinations for a 20 horse field. If you want to look into trying it. I forget from where I got the code but it places each horse number in a separate cell. I had to concatenate the results for my needs. This would automate it to where I wouldn't have to paste the combinations each time which would be impossible in real time for wagering purposes. Here is the code I have If you want to try to include it into your code to automate this more.

Sub HorseRace()
Dim rng1 As Range, rCell As Range, lastRow1 As Long, lastrRow2 As Long
Dim winner As String, placer As String, shower As String, rngHorse As Range
Dim rngFull As Range
Dim w1 As String, p1 As String, s1 As String
Dim w2 As Range, p2 As Range, s2 As Range
Dim w3 As Single, p3 As Single, s3 As Single

lastRow = ThisWorkbook.Sheets("input").Range("f4").End(xlDown).Row
Set rngHorse = ThisWorkbook.Sheets("input").Range("b4:b" & lastRow)
Set rng1 = ThisWorkbook.Sheets("input").Range("f4:f" & lastRow)
Set rngFull = ThisWorkbook.Sheets("input").Range("b4:h" & lastRow)
Count = 0

For Each rCell In rng1
'Parse the cell to get three components
winner = makeParts(rCell.Value)(0)
placer = makeParts(rCell.Value)(1)
shower = makeParts(rCell.Value)(2)

'check the probabilities using find function
Set w2 = rngHorse.Find(winner, LookIn:=xlValues, lookat:=xlWhole)
w1 = w2.Address
w3 = Range(Replace(w1, "$", "")).Offset(0, 1).Value
Set p2 = rngHorse.Find(placer, LookIn:=xlValues, lookat:=xlWhole)
p1 = p2.Address
p3 = Range(Replace(p1, "$", "")).Offset(0, 1).Value
Set s2 = rngHorse.Find(shower, LookIn:=xlValues, lookat:=xlWhole)
s1 = s2.Address
s3 = Range(Replace(s1, "$", "")).Offset(0, 1).Value

'Formula as given by Ringer to be placed in 3 columns offset
rCell.Offset(0, 1).Value = w3 * ((p3 / (1 - w3))) * (s3 / (1 - (w3 + p3)))
Count = Count + 1
Next rCell

End Sub

Function makeParts(valInput As String) As Variant()

Dim Parts() As String
Dim r1 As Integer, r2 As Integer, r3 As Integer

On Error Resume Next
Parts = Split(valInput, "-")
r1 = Parts(0)
r2 = Parts(1)
r3 = Parts(2)
makeParts = Array(r1, r2, r3)

End Function

TheRinger · Aug 4, 2016

Sorry I posted wrong code. Cannot edit it at this time. I will fix when I am able.

TheRinger · Aug 4, 2016

Here is the correct code: Sorry I will edit my mistake ASAP. I am locked out of editing right now?

Sub test()
Dim x As Integer, y As Integer, z As Integer, a As Long
Dim MyArray, Counter As Long

a = WorksheetFunction.Permut(20, 3)

ReDim MyArray(1 To a, 1 To 3)
For x = 1 To 20
For y = 1 To 20
For z = 1 To 20
If x <> y And x <> z And y <> z Then
Counter = Counter + 1
MyArray(Counter, 1) = x
MyArray(Counter, 2) = y
MyArray(Counter, 3) = z
End If
Next z
Next y
Next x
Range("A2").Resize(a, 3) = MyArray
End Sub

TheRinger · Aug 4, 2016

Found the writer of Permutations code above Jay Pertulis on this forum. March 27th 2015.

Meesam_ali · Aug 5, 2016

Ok i will look into it and surely for me i won't stop until OUR project is finished. I am excel enthusiast and won't rest until job is done

TheRinger · Aug 6, 2016

Awesome, I like your way of thinking and appreciative to hear OUR project is worthy of your time.

TheRinger · Aug 6, 2016

Hello Meesam, I know you are looking into the code generating both the combination and the applicable probability together. I thought about a scenario it would run into and tested it. I found that if say #2 were to be scratched from the race ( cell C4 post #11 had a hyphen rather than a probability) the code has Run-time error '13': Type Mismatch. Is this correctable?

Meesam_ali · Aug 7, 2016

Ok man here I am back. First using our original table now the following table will ALSO generate the trifecta combo based on number of horses from the "B" column and then using the combinations will calculate the probabilities. Please try it and let me know where to move then.

Code:

Sub HorseRace()
Dim rngTri As Range, rCell As Range, lastRowTrifecta As Long, lastRowHorse As Long
Dim winner As String, placer As String, shower As String, rngHorse As Range
Dim w1 As String, p1 As String, s1 As String
Dim w2 As Range, p2 As Range, s2 As Range, i As Long
Dim w3 As Single, p3 As Single, s3 As Single
Dim nHorse As Long, rngPermut As Range, combinations As Long


lastRowHorse = ThisWorkbook.Sheets("input").Range("b3").End(xlDown).Row
Set rngHorse = ThisWorkbook.Sheets("input").Range("b3:b" & lastRowHorse)


count = 0


For Each rCell In rngHorse
    nHorse = nHorse + 1
Next


'--------Below is code for making permutations based on number of horses and in sets of three (03)


Dim x As Integer, y As Integer, z As Integer
Dim Counter As Long


For x = 1 To nHorse
    For y = 1 To nHorse
        For z = 1 To nHorse
            If x <> y And x <> z And y <> z Then
                Counter = Counter + 1
                Range("B2").Offset(Counter, 4).Value = x & "-" & y & "-" & z
            End If
        Next z
    Next y
Next x


lastRowTrifecta = ThisWorkbook.Sheets("input").Range("f3").End(xlDown).Row
Set rngTri = ThisWorkbook.Sheets("input").Range("f3:f" & lastRowTrifecta)


For Each rCell In rngTri
    'Parse the cell to get three components
    winner = makeParts(rCell.Value)(0)
    placer = makeParts(rCell.Value)(1)
    shower = makeParts(rCell.Value)(2)
    
    'check the probabilities using find function
        Set w2 = rngHorse.Find(winner, LookIn:=xlValues, lookat:=xlWhole)
            w1 = w2.Address
            w3 = Range(Replace(w1, "$", "")).Offset(0, 1).Value
        Set p2 = rngHorse.Find(placer, LookIn:=xlValues, lookat:=xlWhole)
            p1 = p2.Address
            p3 = Range(Replace(p1, "$", "")).Offset(0, 1).Value
        Set s2 = rngHorse.Find(shower, LookIn:=xlValues, lookat:=xlWhole)
            s1 = s2.Address
            s3 = Range(Replace(s1, "$", "")).Offset(0, 1).Value
    
    'Formula as given by Ringer to be placed in 3 columns offset
    rCell.Offset(0, 1).Value = w3 * ((p3 / (1 - w3))) * (s3 / (1 - (w3 + p3)))
    count = count + 1
Next rCell


End Sub
Function makeParts(valInput As String) As Variant()
  
  Dim Parts() As String
  Dim r1 As Integer, r2 As Integer, r3 As Integer
  
  On Error Resume Next
  Parts = Split(valInput, "-")
  r1 = Parts(0)
  r2 = Parts(1)
  r3 = Parts(2)
  makeParts = Array(r1, r2, r3)
  
End Function

TheRinger · Aug 8, 2016

Meesam the code is great and is working like a charm. I have found a solution to the situation of a scratched horse in the race. Let me put a sheet together and we will see where we are on this project.

Need VBA Code for "permutations" and probablities

TheRinger

New Member

Meesam_ali

Board Regular

Excel Facts

TheRinger

New Member

TheRinger

New Member

TheRinger

New Member

TheRinger

New Member

Meesam_ali

Board Regular

TheRinger

New Member

TheRinger

New Member

Meesam_ali

Board Regular

TheRinger

New Member

Similar threads

Forum statistics

Share this page

Need VBA Code for "permutations" and probablities

New Member

Board Regular

Excel Facts

New Member

New Member

New Member

New Member

Board Regular

New Member

New Member

Board Regular

New Member

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