Hi,
I am totally frustrated and hope someone can solve my macro problem.
I have a macro that should do the following:
When the clock is 00:05:49 (and the same on 00:05:48 as sometimes the clock jumps without showing the first time) several cells should get cleared. - This macro part has the name : "DeleteoldCommands" and is based on Sheet1.
When the clock is 00:05:39 (and the same on 00:05:38 as sometimes the clock jumps without showing the first time) the macro should automatically trigger a LAY bet against the favorite depending on a special cell in which a parameter is calculated by formula. This macro part has the name : "StartTradingsignal" and is based on Sheet1.
Both macro parts are included in the worksheet change section.
Then the macro is told to wait for 4 minutes and 19 seconds before the initial bet should be greened automatically whatever the outcome is by sending the command BACK-SP to column Q. What happens here is that a trigger called "GREENUP-CLEAR" (programmed by Gary) is sent to Q5:Q24. This macro part has the name : "GreeningTradingsignal" and is based on Module.
In the backround several macro parts (all programmed by Gary) calculate the correct stake and odds to settle the greening bet.
By appearence of the "GREENUP-CLEAR" trigger in column Q the calculated stake, odd and command (BACK-SP) for the greening will be copied to column AJ, AK and AL and column T (Bet Ref) gets cleared.
Now the trigger command disappears in column Q and the greening command "BACK-SP" will be copied from column AL to column what will trigger the greening bet. This macro part has the name : "CarryOver" and is based on Module.
GreeningTradingsignal and CarryOver are not part of the worksheet change section but are both included in the macro code of "StartTradingsignal" so indirectly they are part of the worksheet change section. May be that´s the problem ???????
THAT ALL WORKS !!!
But instead of stopping now, the macro goes into an endless loop ( I don´t know why) sending the BACK-SP command again and again to column Q and also sending the GREENUP CLEAR command to all ozher cells in column Q. As the Bet Ref cell is filled, that causes no damage at first, but when a new market is loaded the bet ref is cleared and a Back bet on a horse in the new race gets fired ( of course that should not happen). Then the hole Excel file does not respond any more as it is in an endless loop and the cpu is at 100%.
I think it must have something to do with the contents of the worksheet change section (which macro parts must be included here and which must not be here) and maybe the location (Module or Sheet1) of the several macro parts, but I can´t identify the problem.
Please let me know if you need further information or if I should send you my Excel file. I hope, someone can help me, as I have no further ideas.
See the code below !
Thanks very much and best regards
Stefan
---------------------------
Code on Sheet1:
---------------------------
Private ifWin() As Currency
Private ifLose() As Currency
Private selecIndex As New Collection
Private plRange As Range, pl As Variant, levelPLRange As Range
Private currentMarket As String
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.Columns.Count = 16 Then
calcGreenUp
checkGreenUpTrigger
End If
If Target.Columns.Count >= 1 Then
DeleteoldCommands
StartTradingsignal
End If
Application.EnableEvents = True
End Sub
Private Sub calcGreenUp()
Dim r As Integer, i As Integer
Dim selecName As String
Dim stake As Currency, odds As Currency, win As Currency, lose As Currency, diff As Currency, betType As String
Dim idx As Integer
Dim myBetsRange As Range
Dim betRef As String
r = 2
ReDim ifWin(100)
ReDim ifLose(100)
Set myBetsRange = Worksheets("MyBets").Cells
If currentMarket <> Cells(1, 1) Then initMarket
pl = plRange
currentMarket = Cells(1, 1)
Do
' calculate win and lose positions
If myBetsRange.Cells(r, 5).Value = "F" Then
selecName = myBetsRange.Cells(r, 2).Value
idx = getIndex(selecName)
If idx <> -1 Then
betRef = Cells(idx + 5, 20).Value
stake = myBetsRange.Cells(r, 3).Value
odds = myBetsRange.Cells(r, 4).Value
If myBetsRange.Cells(r, 1).Value = betRef Then ' only include last bet made against this selection
If myBetsRange.Cells(r, 6).Value = "B" Then
ifWin(idx) = ifWin(idx) + (stake * (odds - 1))
ifLose(idx) = ifLose(idx) - stake
Else
ifWin(idx) = ifWin(idx) - (stake * (odds - 1))
ifLose(idx) = ifLose(idx) + stake
End If
End If
End If
End If
r = r + 1
Loop Until myBetsRange.Cells(r, 1).Value = ""
' calculate green up stakes
For r = 5 To 50
getIfWinLose Cells(r, 1).Value, win, lose
If win = lose Then
betType = ""
stake = 0
odds = 0
End If
If win > lose Then
betType = "LAY-SP"
diff = win - lose
odds = Cells(r,
.Value
If odds <> 0 Then
stake = diff / odds
Else
stake = 0
End If
End If
If win < lose Then
betType = "BACK-SP"
diff = lose - win
odds = Cells(r, 6).Value
If odds <> 0 Then
stake = diff / odds
Else
stake = 0
End If
End If
If stake < 0.01 Then
stake = 0
odds = 0
betType = ""
End If
Cells(r, 25).Value = betType
Cells(r, 26).Value = stake
Cells(r, 27).Value = odds
calculateFuturePL r - 4, betType, stake, odds
Next
levelPLRange = pl
End Sub
Private Sub calculateFuturePL(r As Integer, betType As String, stake As Currency, odds As Currency)
Dim i As Integer
For i = 1 To UBound(pl)
If betType = "BACK-SP" Then
If i = r Then
pl(i, 1) = pl(i, 1) + (stake * (odds - 1))
Else
pl(i, 1) = pl(i, 1) - stake
End If
Else
If i = r Then
pl(i, 1) = pl(i, 1) - (stake * (odds - 1))
Else
pl(i, 1) = pl(i, 1) + stake
End If
End If
Next
End Sub
Private Sub initMarket()
Dim r As Integer
Set selecIndex = New Collection
r = 5
Do
r = r + 1
Loop Until Cells(r, 1) = ""
Set plRange = Range(Cells(5, 24), Cells(r - 1, 24))
Set levelPLRange = Range(Cells(5, 28), Cells(100, 28))
levelPLRange = ""
Set levelPLRange = Range(Cells(5, 28), Cells(r - 1, 28))
End Sub
Private Function getIndex(selecName As String) As Integer
Dim idx As Integer
Dim r As Integer
Dim found As Boolean
On Error GoTo index_not_found
idx = selecIndex(selecName)
getIndex = idx
Exit Function
index_not_found:
On Error GoTo 0
r = 4
found = False
Do
r = r + 1
If Cells(r, 1).Value = selecName Then
selecIndex.Add r - 5, selecName
found = True
End If
Loop Until found Or Cells(r, 1).Value = ""
If found Then getIndex = r - 5 Else getIndex = -1
End Function
Private Sub getIfWinLose(selecName As String, ByRef win As Currency, ByRef lose As Currency)
Dim idx As Integer
On Error GoTo index_not_found
idx = selecIndex(selecName)
win = ifWin(idx)
lose = ifLose(idx)
Exit Sub
index_not_found:
On Error GoTo 0
win = 0
lose = 0
End Sub
Private Sub checkGreenUpTrigger()
Dim foundCell As Range, i As Integer, lastR As Integer
Set foundCell = Range("Q4")
Do
lastR = foundCell.Row
Set foundCell = Columns(17).Find(What:="GREENUP-CLEAR", After:=foundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If foundCell Is Nothing Then Exit Do
If foundCell.Row > lastR Then
Cells(foundCell.Row, 36) = Cells(foundCell.Row, 26)
Cells(foundCell.Row, 37) = Cells(foundCell.Row, 27)
Cells(foundCell.Row, 38) = Cells(foundCell.Row, 25)
Cells(foundCell.Row, 20) = ""
End If
Loop Until foundCell.Row <= lastR
End Sub
Sub StartTradingsignal()
For i = 5 To 24
Area1 = "Q" & i
Area2 = "AG" & i
On Error GoTo Ende
Time1 = CStr(CVDate(Sheets("Sheet1").Range("D2")))
Time2 = CStr(CVDate(TimeSerial(0, 5, 39)))
On Error GoTo 0
If Time1 = Time2 Then
If Sheets("Sheet1").Range(Area2) = "1" And Sheets("Sheet1").Range("V30") <> "keine Wette" Then
Sheets("Sheet1").Range(Area1) = "LAY"
End If
End If
Next
For i = 5 To 24
Area1 = "Q" & i
Area2 = "AG" & i
On Error GoTo Ende
Time1 = CStr(CVDate(Sheets("Sheet1").Range("D2")))
Time3 = CStr(CVDate(TimeSerial(0, 5, 38)))
On Error GoTo 0
If Time1 = Time3 Then
If Sheets("Sheet1").Range(Area2) = "1" And Sheets("Sheet1").Range("V30") <> "keine Wette" Then
Sheets("Sheet1").Range(Area1) = "LAY"
End If
End If
Next
Area3 = "T5:T24"
If Application.WorksheetFunction.Sum(Range(Area3)) > 0 And Zähler = 0 Then
Application.OnTime Now + TimeValue("00:04:19"), "GreeningTradingsignal"
End If
CarryOver
Zähler = 1
Ende:
End Sub
Sub DeleteoldCommands()
For i = 5 To 24
Area4 = "AL" & i
Area1 = "T" & i
Area2 = "AJ" & i
Area3 = "AK" & i
On Error GoTo Ende
Time1 = CStr(CVDate(Sheets("Sheet1").Range("D2")))
Time2 = CStr(CVDate(TimeSerial(0, 5, 49)))
On Error GoTo 0
If Time1 = Time2 Then
Sheets("Sheet1").Range(Area4) = ""
Sheets("Sheet1").Range(Area1) = ""
Sheets("Sheet1").Range(Area2) = ""
Sheets("Sheet1").Range(Area3) = ""
End If
Next
For i = 5 To 24
Area4 = "AL" & i
Area1 = "T" & i
Area2 = "AJ" & i
Area3 = "AK" & i
On Error GoTo Ende
Time1 = CStr(CVDate(Sheets("Sheet1").Range("D2")))
Time3 = CStr(CVDate(TimeSerial(0, 5, 48)))
On Error GoTo 0
If Time1 = Time3 Then
Sheets("Sheet1").Range(Area4) = ""
Sheets("Sheet1").Range(Area1) = ""
Sheets("Sheet1").Range(Area2) = ""
Sheets("Sheet1").Range(Area3) = ""
End If
Next
Zähler = 0
Zähler_1 = 0
Ende:
End Sub
--------------------
Code on Module:
--------------------
Private ifWin() As Currency
Private ifLose() As Currency
Private selecIndex As New Collection
Private plRange As Range, pl As Variant, levelPLRange As Range
Private currentMarket As String
Public Zähler As Integer
Public Zähler_1 As Integer
Function getPrevOdds(ByVal odds As Currency) As Currency
Dim oddsInc As Currency
Select Case odds
Case 1.01 To 2
oddsInc = 0.01
Case 2.02 To 3
oddsInc = 0.02
Case 3.05 To 4
oddsInc = 0.05
Case 4.1 To 6
oddsInc = 0.1
Case 6.2 To 10
oddsInc = 0.2
Case 10.5 To 20
oddsInc = 0.5
Case 21 To 30
oddsInc = 1
Case 32 To 50
oddsInc = 2
Case 55 To 100
oddsInc = 5
Case 110 To 1000
oddsInc = 10
End Select
If Math.Round(odds - oddsInc, 2) >= 1.01 Then
getPrevOdds = Math.Round(odds - oddsInc, 2)
Else
getPrevOdds = 1.01
End If
End Function
Function getNextOdds(ByVal odds As Currency) As Currency
Dim oddsInc As Currency
Select Case odds
Case 1 To 1.99
oddsInc = 0.01
Case 2 To 2.98
oddsInc = 0.02
Case 3 To 3.95
oddsInc = 0.05
Case 4 To 5.9
oddsInc = 0.1
Case 6 To 9.8
oddsInc = 0.2
Case 10 To 19.5
oddsInc = 0.5
Case 20 To 29
oddsInc = 1
Case 30 To 48
oddsInc = 2
Case 50 To 95
oddsInc = 5
Case 100 To 1000
oddsInc = 10
End Select
If Math.Round(odds + oddsInc, 2) <= 1000 Then
getNextOdds = Math.Round(odds + oddsInc, 2)
Else
getNextOdds = 1000
End If
End Function
Function plusTicks(odds As Currency, ticks As Byte) As Currency
Dim i As Byte
For i = 1 To ticks
odds = getNextOdds(odds)
Next
plusTicks = odds
End Function
Function minusTicks(odds As Currency, ticks As Byte) As Currency
Dim i As Byte
For i = 1 To ticks
odds = getPrevOdds(odds)
Next
minusTicks = odds
End Function
Sub GreeningTradingsignal()
Do Until Sheets("Sheet1").Range("E2") <> "Suspended"
Application.Wait Now + TimeValue("00:00:01")
Zähler_1 = Zähler_1 + 1
If Zähler_1 > 19 Then Exit Do
Exit Do
Loop
For d = 5 To 24
Area4 = "Q" & d
Sheets("Sheet1").Range(Area4) = "GREENUP-CLEAR"
Next
End Sub
Sub CarryOver()
Dim foundCell As Range, i As Integer, lastR As Integer
Set foundCell = Range("AL4")
Do
lastR = foundCell.Row
Set foundCell = Columns(38).Find(What:="BACK-SP", After:=foundCell, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True)
If foundCell Is Nothing Then Exit Do
If foundCell.Row > lastR Then
Cells(foundCell.Row, 17) = Cells(foundCell.Row, 38)
End If
Loop Until foundCell.Row <= lastR
End Sub