Tracking a staking system problem, stop at x%

ad9051,

I took a look at the example file, and I have a few questions.

• Where do you want the output? (Should it be somewhere on the same sheet as the data, or on a new sheet, etc)
• In your example results, the start for 10/25/2011 is 100, and then end for 10/25/2011 is 73.97004 and you state that that is row 410. Row 410 contains the last cell dated 10/25/2011 for column A, but the last cell dated 10/25/2011 for column B is 414 (results are identical though). Does that mean you want start/end to go off of the dates in column A?
• For 10/26/2011 the start is 73.97004 and a 2% increase would be 75.44943809 or higher. The first row containing a number exceeding that for 10/26/2011 is 898 with a value of 75.9054 but in your example results, you state the finish is on row 962 with a result of 87.08526 so I'm confused on what the logic is behind how you got that result vs the explanation given.

Alan,

I'm afraid I don't fully understand the requirements or logic used to reach the intended results. Referencing a threshold cell is easy enough, but can you walk me through, step by step, the logic used to accomplish the goal?

Alan,

Attached is a modified version of your most recent example file. After modifications, I was at 1.02 MB so I had to zip it to attach it here.

I don't think I fully understand all the requirements because the macro I came up with seemed to hit some "False Positives". As far as how to prevent that, should the macro look at the end of day line first, and if it does not meet or exceed the profit threshold, there were no winners for the day? Even if, at some point during the day, the threshold was exceeded?

Anyway, here's the macro I came up with. I commented it as much as I could so you can alter it as needed. At least it's a starting point:

Sub tgr()
    
    Dim rngDate As Range
    Dim rngVis As Range
    Dim DateVal As Double
    Dim arrData As Variant
    Dim DataIndex As Long
    Dim BankStart As Double
    Dim BankStop As Double
    Dim ProfitThreshold As Double
    Dim WinAchieved As Boolean
    Dim arrResults() As Variant
    ReDim arrResults(1 To 5, 1 To Rows.Count)
    Dim ResultIndex As Long
    Dim strYesNone As String
    Dim DateFormat As String
    
    'Disable screenupdating, events, and autocalc to allow macro to run faster
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    'Get the profit threshold % from cell E4
    ProfitThreshold = Range("E4").Value2
    
    'This is the range in column B containing the dates
    Set rngDate = Range(Cells(1, "B").End(xlDown).Offset(-1), Cells(Rows.Count, "B").End(xlUp))
    
    'Set this to the desired date format
    DateFormat = "m/d/yyyy"
    
    With rngDate
        'Change the dates to numbers to avoid date formatting issues
        .NumberFormat = "General"
        
        'Sort the dates ascending to make processing easier.  This line may not be necessary if the data is already sorted
        Intersect(.EntireRow, Range("A:K")).Sort Range(.Address), xlAscending, Header:=xlYes
        
        'Start a loop going from the first date to the last date
        'This loop happens once for each whole day
        For DateVal = rngDate.Cells(2).Value2 To rngDate.Cells(rngDate.Cells.Count).Value2
            
            'Filter the data for the current DateVal so that we're working with just that day
            .AutoFilter 1, DateVal
            
            'Get the range of visible cells after the filter
            Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            
            'Load the visible "H" cell values into an array
            'I used column H because it seemed to contain the bank values we're looking at
            arrData = Application.Transpose(Intersect(rngVis.EntireRow, Columns("H")).Value2)
            
            'Assign values to variables before looping through the bank data for the day
            WinAchieved = False                             'Win hasn't been achieved yet (haven't looked yet)
            strYesNone = "None"                             'This variable declares whether a win was achieved or not for the day
            BankStart = arrData(LBound(arrData))            'Gets the bank's starting value for the day
            BankStop = BankStart * (1 + ProfitThreshold)    'Gets the stop threshold
            
            'Loop through the bank data for the day
            For DataIndex = LBound(arrData) + 1 To UBound(arrData)
                'If the bank data equals or exceeds the bankstop, then a win has been achieved, and exit the loop
                If arrData(DataIndex) >= BankStop Then
                    WinAchieved = True
                    strYesNone = "Yes"
                    Exit For
                End If
            Next DataIndex
            If Not WinAchieved Then DataIndex = UBound(arrData)
            
            'Increases ResultIndex and populates Results Array
            ResultIndex = ResultIndex + 1
            arrResults(1, ResultIndex) = DateVal
            arrResults(2, ResultIndex) = BankStart
            arrResults(3, ResultIndex) = strYesNone
            arrResults(4, ResultIndex) = arrData(DataIndex)
            arrResults(5, ResultIndex) = rngDate.Find(DateVal, , xlValues, xlWhole).Row + DataIndex - LBound(arrData)
            
        Next DateVal    'Advance loop to perform these operations on the next day
        
        .AutoFilter                 'Now that all days have been processed, remove the filter
        .NumberFormat = DateFormat  'Change the format back to the DateFormat
    End With
    
    'If there are results, output them to the sheet, starting at M36
    If ResultIndex > 0 Then
        ReDim Preserve arrResults(1 To 5, 1 To ResultIndex)
        With Range("M36:Q36").Resize(ResultIndex)
            .Value = Application.Transpose(arrResults)
            .Resize(, 1).NumberFormat = DateFormat
        End With
    End If
    
    'Re-enable screenupdating, events, and autocalc
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

Alan,

Made some changes to the code. It now clears the L column and puts in the 1's in the L column where appropriate. It uses the arrays in column A to check if a win actually happened or not. Let me know if it is now returning the correct results, or if it still needs tweaking.

Sub tgr()
    
    Dim rngDate As Range
    Dim rngVis As Range
    Dim VisGrp As Range
    Dim DateVal As Double
    Dim arrData As Variant
    Dim DataIndex As Long
    Dim BankStart As Double
    Dim BankStop As Double
    Dim ProfitThreshold As Double
    Dim BankValue As Double
    Dim WinAchieved As Boolean
    Dim arrResults() As Variant
    ReDim arrResults(1 To 5, 1 To Rows.Count)
    Dim ResultIndex As Long
    Dim rIndex As Long
    Dim strYesNone As String
    Dim DateFormat As String
    
    'Disable screenupdating, events, and autocalc to allow macro to run faster
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    'Clear column L
    Columns("L").ClearContents
    
    'Get the profit threshold % from cell E4
    ProfitThreshold = Range("E4").Value2
    
    'This is the range in column B containing the dates
    Set rngDate = Range(Cells(1, "B").End(xlDown).Offset(-1), Cells(Rows.Count, "B").End(xlUp))
    
    'Set this to the desired date format
    DateFormat = "m/d/yyyy"
    
    With rngDate
        'Change the dates to numbers to avoid date formatting issues
        .NumberFormat = "General"
        
        'Sort the dates ascending to make processing easier.  This line may not be necessary if the data is already sorted
        Intersect(.EntireRow, Range("A:K")).Sort Range(.Address), xlAscending, Header:=xlYes
        
        'If a day is skipped, it could cause an error
        'This will prevent that and proceed to the next day
        On Error Resume Next
        
        'Start a loop going from the first date to the last date
        'This loop happens once for each whole day
        For DateVal = .Cells(2).Value2 To .Cells(.Cells.Count).Value2
            
            'Filter the data for the current DateVal so that we're working with just that day
            .AutoFilter 1, DateVal
            
            'Get the range of visible cells after the filter
            Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            
            'Check if data for this day exists
            If Not rngVis Is Nothing Then
                If Not rngVis.Offset(, -1).Find("*") Is Nothing Then
                    
                    'Found data for this day exists, perform operations
                    'Assign values to variables before looping through the bank data for the day
                    WinAchieved = False                             'Win hasn't been achieved yet (haven't looked yet)
                    strYesNone = "None"                             'This variable declares whether a win was achieved or not for the day
                    BankStart = Cells(rngVis.Row, "K").Value2       'Gets the bank's starting value for the day
                    BankStop = BankStart * (1 + ProfitThreshold)    'Gets the stop threshold
                    
                    'Loop through the bank data for the day, going by the arrays in column A
                    For Each VisGrp In rngVis.Offset(, -1).SpecialCells(xlCellTypeConstants).Areas
                        'If the bank data equals or exceeds the bankstop, then a win has been achieved, and exit the loop
                        If VisGrp.Cells(VisGrp.Cells.Count).Offset(, 10).Value2 >= BankStop Then
                            WinAchieved = True
                            strYesNone = "Yes"
                            
                            'Populate column L with 1's until end of day
                            Range("L" & VisGrp.Row + VisGrp.Rows.Count & ":L" & rngVis.Row + rngVis.Rows.Count - 1).Value = 1
                            Calculate
                            
                            'Load the visible "K" cell values into an array to find exact row and values
                            arrData = Application.Transpose(Intersect(VisGrp.EntireRow, Columns("K")).Value2)
                            For DataIndex = LBound(arrData) To UBound(arrData)
                                If arrData(DataIndex) >= BankStop Then
                                    BankValue = arrData(DataIndex)
                                    rIndex = VisGrp.Row + DataIndex - LBound(arrData)
                                    Exit For
                                End If
                            Next DataIndex
                            
                            Exit For
                        End If
                    Next VisGrp
                    
                    If Not WinAchieved Then
                        BankValue = rngVis.Cells(rngVis.Cells.Count).Offset(, 9).Value
                        rIndex = rngVis.Row + rngVis.Rows.Count - 1
                    End If
                    
                    'Increases ResultIndex and populates Results Array
                    ResultIndex = ResultIndex + 1
                    arrResults(1, ResultIndex) = DateVal    'Date
                    arrResults(2, ResultIndex) = BankStart  'Bank start value
                    arrResults(3, ResultIndex) = strYesNone 'Yes or None depending on if a win was achieved
                    arrResults(4, ResultIndex) = BankValue  'The bank value when the win was achieved or the end of day bank value if a win was not achieved
                    arrResults(5, ResultIndex) = rIndex     'The row number of the bank value
                    
                End If
            End If
            
        Next DateVal    'Advance loop to perform these operations on the next day
        
        'Clear On Error Resume Next functionality
        On Error GoTo 0
        
        .AutoFilter                 'Now that all days have been processed, remove the filter
        .NumberFormat = DateFormat  'Change the format back to the DateFormat
    End With
    
    'If there are results, output them to the sheet, starting at M36
    If ResultIndex > 0 Then
        ReDim Preserve arrResults(1 To 5, 1 To ResultIndex)
        With Range("M36:Q36").Resize(ResultIndex)
            .Value = Application.Transpose(arrResults)
            .Resize(, 1).NumberFormat = DateFormat
        End With
    End If
    
    'Re-enable screenupdating, events, and autocalc
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

You're welcome, and I'm glad to hear that did the trick