excel function Fair(par) exacta Grid for all odd combos

[asH]

excel function: Fair (par ) exacta grid
Here is a function I wrote that gives a par exacta grid for all horse odds in a race using the Harvell formula. simple to use add as a macro .


odds can be written as 5-2, 1-1, 4/5, 1.50, 4 ...

start by typing a list of odds down a column

c4- any cell above the odds (leave 3 rows above free,1 to the left

4/5

4

4-1

45

15

9/11 -yeah over seas odds too



run the macro, when asked enter the empty cell above the odds list you entered ...

will produce an exacta grid of par odd exacta for all combinations in a race max is 20 horses but no limit as I know yet have to change the array and count to match.



things to know- this is a function in raw form, no error handling..but very few program errors. no bells and whistles yet...working on other bits.

have fun

asH

'When considering the attractiveness of an exacta bet, a quinella bet,

'or a place or show bet, it is necessary to have a good estimate of a

'horse’s chance of coming in second. If you already have a good estimate

'of the true probabilities of each horse winning a race, then the Harville

'formula gives a reasonable estimate of the probability that a given horse

'will come in 2nd. asH



Dim test(1 To 20) As Double

Dim lengthA, lengthB, endofline, i, x, y As Integer

Dim lenNumer1, domin1, domin2, winpercentage1, winpercentage2 As Variant

Dim secondplacepercent, exacta2 As Variant

Dim dollarOROdds As String

Dim Myrange As Range

Dim again As Boolean



Set Myrange = Application.InputBox _

(Prompt:="Select a cell above the list of odds", Title:="ParExacta", Type:=8)

Myrange.Select



For i = 1 To 20 ' max 20..add as many as u like just change the test array above to match



Myrange.Offset(-2, -1).Formula = "Win Percentage"

Myrange.Offset(0, 0).Formula = "Odds"

Myrange.Offset(-1, -1).Formula = "P.P."

Myrange.Offset(0, i).Value = Myrange.Offset(i, 0).Value

Myrange.Offset(0, i).Font.Bold = True

Myrange.Offset(i, 0).Font.Bold = True

Myrange.Offset(-2, -1).Font.Bold = True

Myrange.Offset(0, 0).Font.Bold = True

Myrange.Offset(-1, -1).Font.Bold = True



If Myrange.Offset(i) = "" Then i = i + 1: Exit For

odds1 = Myrange.Offset(i) '

'convert to int

numer1 = Val(odds1) ' strip #

lengthA = Len(numer1) ' measure length

lengthB = Len(odds1) 'length before

'compare

If lengthA = lengthB Then dollarOROdds = "dollar"

If lengthA < lengthB Then dollarOROdds = "odds"





Select Case dollarOROdds

Case "odds"

lengthA = Len(odds1) 'length of odds

numer1 = Val(odds1) ' strip the numerator

lenNumer1 = Len(numer1) ' length of the numerator

domin1 = Mid(odds1, lenNumer1 + 2) ' find the denom

domin1 = Val(domin1) ' convert the denom

winpercent1 = 1 - (numer1 / (numer1 + domin1)) 'win percentage of first

If winpercent1 = "1" Then winpercent1 = "0"

Case "dollar"

numer1 = Val(odds1) ' strip the numerator

winpercent1 = 1 - (numer1 / (numer1 + 1))

If winpercent1 = "1" Then winpercent1 = "0"

End Select



'end of con.

' this area reserved for cell and font formatting

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx



'format area cells, font,color

test(i) = winpercent1

endofline = i

Myrange.Offset(-2, i).Value = test(i)

Myrange.Offset(-1, i).Value = (i)

Myrange.Offset(i, -1).Value = (i)

Next i



For y = 1 To endofline ' start matrix

For x = 1 To endofline

'

Do 'trap

again = False

If y = x Then x = x + 1: again = yes 'x row second, y column first

If (endofline * 2) = (x + y) - 2 Then Exit Do

If test(x) = 0 Then x = x + 1: again = True

If test(y) = 0 Then y = y + 1: again = True

Loop Until again = False



If x > endofline Then Exit For '



winpercent2 = test(x)

winpercent1 = test(y)

'chance as percent horse comes in second py, after horse pz comes in first = PY/(1-PZ)

'Harville’s exacta formula



secondplacepercent = winpercent2 / (1 - winpercent1)

exacta2 = 2 * (1 / (secondplacepercent * winpercent1))

Myrange.Offset(x, y).Value = exacta2 'a place in the xy grid



Next x

If y > endofline Then Exit For 'safety valve

Next y



End Sub

[asH]

oh yeah format the whole grid area as "TexT" for best results...until I add cell formating.

asH

[asH]

scratched horse position is entered as a zero... "0" if needed

asH

[HUSKER55]

I was going to try playing with the function you created and I discovered a problem. I may not be smart enough.

What is a Harvell function and does it have a different name. My excel is 2003.

Thanks

[WeirdWilly]

I was going to try playing with the function you created and I discovered a problem. I may not be smart enough.

What is a Harvell function and does it have a different name. My excel is 2003.

Thanks

Try Googling "Harville Formula"

[HUSKER55]

found it!!!


Thanks for the help :)

[asH]

now all you have to do is click on the cell above the list of odds (input box is gone..active cell is the last cell clicked before the macro) , then run the macro (best if attached to a button- then just click on the cell above the list, press button to start)..clears and resets the range.....more to come... thanks asH

Sub ParExacta2()' asH
Dim test(1 To 20) As Double
Dim lengthA, lengthB, endofline, i, x, y As Integer
Dim lenNumer1, domin1, domin2, winpercentage1, winpercentage2 As Variant
Dim secondplacepercent, exacta2, yeahyeah(1 To 20) As Variant
Dim dollarOROdds As String
Dim Myrange, dee As Range
Dim again As Boolean
Application.ScreenUpdating = False

Range(Cells(1, 1), Cells(5, 3)). _
Font.Italic = True
Set Myrange = activecell
'Application.InputBox _
'(Prompt:="Select the cell above the list of odds", Title:="ParExacta", Type:=8)
Myrange.Select

For i = 1 To 20
yeahyeah(i) = Myrange(i)
Next i
For x = -5 To 20
For y = -5 To 20
Myrange.Offset(x, y).ClearContents
Myrange.Offset(x, y).NumberFormat = "@" 'Value = 'NumSheets("Sheet1")
Myrange.Offset(x, y).Font.Bold = False
Next y
Next x

For i = 1 To 20
Myrange(i) = yeahyeah(i)
Next i

For i = 1 To 20 ' max 20..add as many as u like just 'change the test array above to match

Myrange.Offset(-2, -1).Formula = "Win Percentage"
Myrange.Offset(0, 0).Formula = "Odds"
Myrange.Offset(-1, -1).Formula = "P.P."
Myrange.Offset(0, i).Value = Myrange.Offset(i, 0).Value
Myrange.Offset(0, i).Font.Bold = True
Myrange.Offset(i, 0).Font.Bold = True
Myrange.Offset(-2, -1).Font.Bold = True
Myrange.Offset(0, 0).Font.Bold = True
Myrange.Offset(-1, -1).Font.Bold = True

If Myrange.Offset(i) = "" Then i = i + 1: Exit For
odds1 = Myrange.Offset(i) '
'convert to int
numer1 = Val(odds1) ' strip #
lengthA = Len(numer1) ' measure length
lengthB = Len(odds1) 'length before
'compare
If lengthA = lengthB Then dollarOROdds = "dollar"
If lengthA < lengthB Then dollarOROdds = "odds"


Select Case dollarOROdds
Case "odds"
lengthA = Len(odds1) 'length of odds
numer1 = Val(odds1) ' strip the numerator
lenNumer1 = Len(numer1) ' length of the numerator
domin1 = Mid(odds1, lenNumer1 + 2) ' find the denom
domin1 = Val(domin1) ' convert the denom
winpercent1 = 1 - (numer1 / (numer1 + domin1)) 'win percentage of first
If winpercent1 = "1" Then winpercent1 = "0"
Case "dollar"
numer1 = Val(odds1) ' strip the numerator
winpercent1 = 1 - (numer1 / (numer1 + 1))
If winpercent1 = "1" Then winpercent1 = "0"
End Select

'end of con.
' this area reserved for cell and font formatting
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

'format area cells, font,color
test(i) = winpercent1
endofline = i
Myrange.Offset(-2, i).Value = test(i)
Myrange.Offset(-1, i).Value = (i)
Myrange.Offset(i, -1).Value = (i)
Next i

For y = 1 To endofline ' start matrix
For x = 1 To endofline
'
Do 'trap
again = False
If y = x Then x = x + 1: again = yes 'x row second, y column first
If (endofline * 2) = (x + y) - 2 Then Exit Do
If test(x) = 0 Then x = x + 1: again = True
If test(y) = 0 Then y = y + 1: again = True
Loop Until again = False

If x > endofline Then Exit For '

winpercent2 = test(x)
winpercent1 = test(y)
'chance as percent horse comes in second py, after horse pz comes in first = PY/(1-PZ)
'Harville’s exacta formula

secondplacepercent = winpercent2 / (1 - winpercent1)
exacta2 = 2 * (1 / (secondplacepercent * winpercent1))
Myrange.Offset(x, y).Value = exacta2 'a place in the xy grid

Next x
If y > endofline Then Exit For 'safety valve
Next y
Application.ScreenUpdating = True
End Sub

[asH]

oh yeah! , area now formatted is larger . Area (cells covered )is -5 back and -5 above the active cell (cell above the list of odds) ...stay 5 rows below row 1, and 5 columns from column A
if you need to adjust the matrix area (cells formatted- bold below), too, remember 20 is the max number of horses and odds-...thats what happens at 4:00am in the mornzzzzzzzzzzzz.
again
stay 5 columns away from 1st column, and 5 rows from the top-row 1, this area will be cleared and reformatted..if not out of bounds error will pop up...will correct

(new code)
For i = 1 To 20
yeahyeah(i) = Myrange(i)
Next i
For x = -5 To 20 ' format, clear matrix area
For y = -5 To 20
Myrange.Offset(x, y).ClearContents
Myrange.Offset(x, y).NumberFormat = "@"
Myrange.Offset(x, y).Font.Bold = False
Next y
Next x

asH

[asH]

had time today after the parade (GIANTS) and election

90% complete- structure is sound ..now faster.. warning msg if to close to the edge. now no errors if 0 is last horse...remember 0 is used for scratched horses , or empty positions... ... Another way to use is to just plug in your exacta horses . Can immediately determine overs and unders, couple of hi percentage ones got by at Aqu last week. Would ve added conditional formatting but excel does that already

may incorporate a few ideas from Steve Crist's Exotic Betting.

I needed the practice before major upgrade of my program. drop a line. Add it as an excel macro, connect it to a button for best results, can have more than on running at one time

have fun with it , make money
asH



Sub ParExacta2()

Dim test(1 To 20) As Double
Dim lengthA, lengthB, endofline, i, x, y As Integer
Dim winpercentage1, winpercentage2, GiantsEighteengamesAndWontheSuperbowl(1 To 20, 1 To 20) As Variant
Dim secondplacepercent, exacta2, yeahyeah(1 To 20) As Variant
Dim dollarOROdds As String
Dim Myrange, dee As Range
Dim again, Patriots19GiantsWontheSuperBowl As Boolean
Application.ScreenUpdating = False
Patriots19GiantsWontheSuperBowl = True

If ActiveCell.Row < 3 Then
MsgBox "Begin grid 3 rows and 3 columns from edge. " & " Row is at position " & ActiveCell.Row, vbCritical, "error": End
End If
If ActiveCell.Column < 3 Then
MsgBox "Begin grid 3 rows and 3 columns from edge." & " Column at position " & ActiveCell.Column, vbCritical, "error": End
End If

Set Myrange = ActiveCell

For i = 1 To 20
yeahyeah(i) = Myrange.Offset(i).Value
If Trim(yeahyeah(i)) = "" Then endofline = i: Exit For
Next i

Set Myrange = ActiveCell.Range(Cells(1, 1), Cells(25, 25))
Myrange.ClearContents
Myrange.NumberFormat = "@" '
Myrange.Font.Bold = False
Myrange.Interior.ColorIndex = 0
Myrange.Font.Size = 11
Myrange.Orientation = center

Set Myrange = ActiveCell.Range(Cells(2, 1), Cells(20, 1))
Myrange.Value = Application.Transpose(yeahyeah)

Set Myrange = ActiveCell
Myrange.Offset(-2, -1).Formula = "Win Percentage"
Myrange.Offset(0, 0).Formula = "Odds"
Myrange.Offset(-1, -1).Formula = "P.P."
Myrange.Offset(-2, -1).Font.Bold = True
Myrange.Offset(0, 0).Font.Bold = True
Myrange.Offset(-1, -1).Font.Bold = True
For i = 1 To endofline
Myrange.Offset(0, i).Value = Myrange.Offset(i, 0).Value
Myrange.Offset(0, i).Font.Bold = True
Myrange.Offset(i, 0).Font.Bold = True
Myrange.Offset(0, i).Interior.ColorIndex = 17
Myrange.Offset(i, 0).Interior.ColorIndex = 17
If i = endofline Then Exit For '(i = i + 1:) take value from array strip, why i+1??, may take off
odds1 = yeahyeah(i) '
'convert to int
numer1 = Val(odds1) ' strip #
lengthA = Len(numer1) ' measure length
lengthB = Len(odds1) 'length before
'compare
If lengthA = lengthB Then dollarOROdds = "dollar"
If lengthA < lengthB Then dollarOROdds = "odds"
Select Case dollarOROdds
Case "odds"
lengthA = Len(odds1) 'length of odds
numer1 = Val(odds1) ' strip the numerator
lenNumer1 = Len(numer1) ' length of the numerator
domin1 = Mid(odds1, lenNumer1 + 2) ' find the denom
domin1 = Val(domin1) ' convert the denom
winpercent1 = 1 - (numer1 / (numer1 + domin1)) 'win percentage of first
If winpercent1 = "1" Then winpercent1 = "0"
Case "dollar"
numer1 = Val(odds1) ' strip the numerator
winpercent1 = 1 - (numer1 / (numer1 + 1))
If winpercent1 = "1" Then winpercent1 = "0"
End Select

'end of con.
' this area reserved for advanced functions
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'format area cells, font,color
test(i) = winpercent1
Myrange.Offset(-2, i).Value = test(i)
Myrange.Offset(-1, i).Value = (i)
Myrange.Offset(i, -1).Value = (i)
Next i

For y = 1 To endofline ' start matrix
For x = 1 To endofline
'
Do 'x y trap
again = False
If x = y Then x = x + 1: again = True

If test(x) = 0 Then x = x + 1: again = True

If x >= endofline And test(x) = 0 Then Exit For 'again = False ,x = x - 1,End If
If y >= endofline And test(y) = 0 Then Exit For
If test(y) = 0 Then y = y + 1: again = True

If (endofline * 2) = (x + y) - 2 Then Exit Do ' again = False

Loop Until again = False

'--------------------------------------------------


'--------------------------------------------------------
If x > endofline Then Exit For '

winpercent2 = test(x)
winpercent1 = test(y)
'chance as percent horse comes in second py, after horse pz comes in first = PY/(1-PZ)
'Harville’s exacta formula
secondplacepercent = winpercent2 / (1 - winpercent1)
exacta2 = 2 * (1 / (secondplacepercent * winpercent1))
GiantsEighteengamesAndWontheSuperbowl(x, y) = exacta2

Next x
If y > endofline Then Exit For 'safety valve
Next y
Set Myrange = ActiveCell.Range(Cells(2, 2), Cells(20, 20))
Myrange.Value = GiantsEighteengamesAndWontheSuperbowl
Application.ScreenUpdating = True

End Sub

[asH]

ParExacta as a function instead of sub routine, it may have given headaches if you were not aware of the change to sub routine, sorry bout that...extra clean-up included...enjoy



Function ParExacta2()
Dim test(1 To 20) As Double
Dim lengthA, lengthB, endofline, i, x, y As Integer
Dim winpercentage1, winpercentage2, GiantsEighteengamesAndWontheSuperbowl(1 To 20, 1 To 20) As Variant
Dim secondplacepercent, exacta2, yeahyeah(1 To 20) As Variant
Dim dollarOROdds As String
Dim Myrange, dee As Range
Dim again, Patriots19GiantsWontheSuperBowl As Boolean
Application.ScreenUpdating = False
Patriots19GiantsWontheSuperBowl = True

If ActiveCell.Row < 3 Then
MsgBox "Begin grid 3 rows and 3 columns from edge. " & " Row is at position " & ActiveCell.Row, vbCritical, "error": End
End If
If ActiveCell.Column < 3 Then
MsgBox "Begin grid 3 rows and 3 columns from edge." & " Column at position " & ActiveCell.Column, vbCritical, "error": End
End If

Set Myrange = ActiveCell

For i = 1 To 20
yeahyeah(i) = Myrange.Offset(i).Value
If Trim(yeahyeah(i)) = "" Then endofline = i: Exit For
Next i

Set Myrange = ActiveCell.Range(Cells(1, 1), Cells(25, 25))
Myrange.ClearContents
Myrange.NumberFormat = "@" '
Myrange.Font.Bold = False
Myrange.Interior.ColorIndex = 0
Myrange.Font.Size = 11
Myrange.HorizontalAlignment = xlCenter



Set Myrange = ActiveCell
For i = -3 To 25
Myrange.Offset(0, i).Interior.ColorIndex = 0
Myrange.Offset(i, 0).Interior.ColorIndex = 0
Myrange.Offset(0, i).Font.Bold = False
Myrange.Offset(i, 0).Font.Bold = False
Myrange.Offset(i, 0).ClearContents
Myrange.Offset(i, 0).ClearContents
Myrange.Offset(-2, i).ClearContents
Myrange.Offset(-1, i).ClearContents
Myrange.Offset(i, -1).ClearContents
Next i

Set Myrange = ActiveCell.Range(Cells(2, 1), Cells(20, 1))
Myrange.Value = Application.Transpose(yeahyeah)


Set Myrange = ActiveCell
Myrange.Offset(-2, -1).Formula = "Win Percentage"
Myrange.Offset(0, 0).Formula = "Odds"
Myrange.Offset(-1, -1).Formula = "P.P."
Myrange.Offset(-2, -1).Font.Bold = True
Myrange.Offset(0, 0).Font.Bold = True
Myrange.Offset(-1, -1).Font.Bold = True
For i = 1 To endofline
Myrange.Offset(0, i).Value = Myrange.Offset(i, 0).Value
Myrange.Offset(0, i).HorizontalAlignment = xlCenter
Myrange.Offset(i, 0).HorizontalAlignment = xlCenter
Myrange.Offset(0, i).Font.Bold = True
Myrange.Offset(i, 0).Font.Bold = True
Myrange.Offset(0, i).Interior.ColorIndex = 17
Myrange.Offset(i, 0).Interior.ColorIndex = 17
If i = endofline Then Exit For '(i = i + 1:) take value from array strip, why i+1??, may take off
odds1 = yeahyeah(i) '
'convert to int
numer1 = Val(odds1) ' strip #
lengthA = Len(numer1) ' measure length
lengthB = Len(odds1) 'length before
'compare
If lengthA = lengthB Then dollarOROdds = "dollar"
If lengthA < lengthB Then dollarOROdds = "odds"

Select Case dollarOROdds
Case "odds"
lengthA = Len(odds1) 'length of odds
numer1 = Val(odds1) ' strip the numerator
lenNumer1 = Len(numer1) ' length of the numerator
domin1 = Mid(odds1, lenNumer1 + 2) ' find the denom
domin1 = Val(domin1) ' convert the denom
winpercent1 = 1 - (numer1 / (numer1 + domin1)) 'win percentage of first
If winpercent1 = "1" Then winpercent1 = "0"
Case "dollar"
numer1 = Val(odds1) ' strip the numerator
winpercent1 = 1 - (numer1 / (numer1 + 1))
If winpercent1 = "1" Then winpercent1 = "0"
End Select

'end of con.
' this area reserved for advanced functions
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
'format area cells, font,color
test(i) = winpercent1
Myrange.Offset(-2, i).Value = test(i)
Myrange.Offset(-1, i).Value = (i)
Myrange.Offset(i, -1).Value = (i)
Next i

For y = 1 To endofline ' start matrix
For x = 1 To endofline
'
Do 'x y trap
again = False

If x = y Then x = x + 1: again = True

If test(x) = 0 Then x = x + 1: again = True

If x >= endofline And test(x) = 0 Then Exit For 'again = False ,x = x - 1,End If
If y >= endofline And test(y) = 0 Then Exit For
If test(y) = 0 Then y = y + 1: again = True

If (endofline * 2) = (x + y) - 2 Then Exit Do ' again = False

Loop Until again = False

'--------------------------------------------------



'--------------------------------------------------------
If x > endofline Then Exit For '

winpercent2 = test(x)
winpercent1 = test(y)
'chance as percent horse comes in second py, after horse pz comes in first = PY/(1-PZ)
'Harville’s exacta formula
secondplacepercent = winpercent2 / (1 - winpercent1)
exacta2 = 2 * (1 / (secondplacepercent * winpercent1))
GiantsEighteengamesAndWontheSuperbowl(x, y) = exacta2

Next x
If y > endofline Then Exit For 'safety valve
Next y
Set Myrange = ActiveCell.Range(Cells(2, 2), Cells(20, 20))
Myrange.Value = GiantsEighteengamesAndWontheSuperbowl
Application.ScreenUpdating = True

End Function