Thread: Time limit on Code Execution

Hi guys,

I'm just wondering if there's a code where i can put a time limit on certain code execution.

For example,

I have a function which will allow me to search for combination of numbers which will sum to zero. However, because the range could be as long as 300 rows or even the possibility of not finding the combination that will sum to zero, the macro will take ages to complete or even causes the whole excel to hang. So What i want is to instruct macro to stop doing the search if it cannot find the results after say 20 minutes of searching.

Is that possible?

Could you use this:

Code:

Sub count()

Dim EndTime As Date
Dim Seconds As Double

Seconds = (1 / 24 / 60 / 60)

EndTime = Now() + 5 * Seconds ' 5 seconds

While Now() < EndTime
  Debug.Print Format((EndTime - Now()) / Seconds, "##.0")
Wend

End Sub

Perhaps I should be a little bit more descriptive.

In the spreadsheet that I have attached, there are 2 sheets which have been labelled. One named "Solution found" and the other "solution cannot be found".

When I run the below code, despite taking ages to run, the macro can provide me with the relevant combination of quantity will sum to zero. This is the one listed in sheet("solution found"). With the other sheet, however, it also take ages but it can never finish executing. It almost appears that the macro has hang. I have even tried executing it overnight and it still looks as if it is running. I do realise that if i try to find the combination myself, it doesn't appear to have any combination that will sum to zero.

So what I want is to add a code so that when the below code is being executed, it can only run for e.g. 20 minutes. If after, 20 minutes it hasn't found a solution yet, just abort and resume next.

The below code was copied from someone and I have tweak it a bit so that it works along with my other codes. Hence, just wondering if there is such a code.

Code:

Sub testen()
Dim varErg As Variant
varErg = Kombinationen(Array(10, 11, 13, 12), 25, 0.5)
End Sub

Public Function Kombinationen( _
   Elemente As Variant, _
   Sollwert As Double, _
   Optional Toleranz As Double, _
   Optional Bisher As Variant, _
   Optional Pos As Long) As Variant
   
Dim i             As Long
Dim k             As Long
Dim dblVergleich  As Double
Dim dblDummy      As Double
Dim varDummy      As Variant
Dim varResult     As Variant


If Not IsMissing(Bisher) Then

   'Summe bisherige Elemente
   For Each varDummy In Bisher
      dblVergleich = dblVergleich + varDummy
   Next
   
Else

   'Ausgangselemente nach Größe sortieren
   For i = 1 To UBound(Elemente)
       For k = i + 1 To UBound(Elemente)
           If Elemente(k) < Elemente(i) Then
               dblDummy = Elemente(i)
               Elemente(i) = Elemente(k)
               Elemente(k) = dblDummy
           End If
       Next
   Next
   
   Set Bisher = New Collection
   
End If

If Pos = 0 Then Pos = LBound(Elemente)
For i = Pos To UBound(Elemente)

   ' Aktuellen Wert hinzufügen
   Bisher.Add Elemente(i)
   dblVergleich = dblVergleich + Elemente(i)
   
   If Abs(Sollwert - dblVergleich) < (0.001 + Toleranz) Then
   
      'Sollwert ist erreicht
      k = 0
      ReDim varResult(0 To Bisher.count - 1, 0)
      For Each varDummy In Bisher
         varResult(k, 0) = varDummy
         k = k + 1
      Next
      Kombinationen = varResult
      Exit For
      
   ElseIf dblVergleich < (Sollwert + 0.001 + Toleranz) Then
      ' Es ist noch Platz für einen Betrag
      ' Rekursiv aufrufen, beginnen mit nächsthöherem Wert
      varResult = Kombinationen( _
         Elemente, Sollwert, Toleranz, Bisher, i + 1)
      If IsArray(varResult) Then
         Kombinationen = varResult
         Exit For
      Else
         Bisher.Remove Bisher.count
         dblVergleich = dblVergleich - Elemente(i)
      End If
      
   Else
   
      ' Wert ist zu groß
      Bisher.Remove Bisher.count
      Exit For
      
   End If
   
Next ' Nächsthöhere Zahl probieren

End Function

Sub finalsubset()
Dim dblZielwert   As Double
Dim dblToleranz   As Double
Dim adblBetrage() As Double
Dim varResult     As Variant
Dim m             As Long
Dim n             As Long

With ActiveSheet
   dblZielwert = .Range("B2") 'target value
   dblToleranz = .Range("C2") 'tolerance value
   ReDim adblBetrage(1 To 100)
   For m = 2 To 101
      If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
         adblBetrage(m - 1) = .Cells(m, 1)
      Else
         ReDim Preserve adblBetrage(1 To m - 1)
         Exit For
      End If
   Next
   ReDim Preserve adblBetrage(1 To UBound(adblBetrage) - 1)
   On Error Resume Next
   varResult = Kombinationen(adblBetrage, dblZielwert, dblToleranz)
   Application.ScreenUpdating = False
      .Range("D2:D65536").ClearContents
      .Range(.Cells(2, 4), .Cells(UBound(varResult) + 2, 4)) = _
         varResult
   Application.ScreenUpdating = True
End With

End Sub

hi,

I've come looking from the below link to see if I can help optimise your code but I can't access the link you've provided (in post 6 of this thread) as it states "no thread specified" & I can't find other possible threads against your username using the site's Search tool.

Can you please re-upload your sample file with all the current code (& all relevant layout*) included?
Also, can you please include column headers to assist with clarity?
*This looks reasonably different when compared to the layout in your other thread(http://www.excelforum.com/excel-prog...g-of-data.html).

btw, This thread is currently in the Excel Programming forum which I think is a valid location for it. Has it been moved?


Rob

This is just air code, but you can probably do this yourself once you understand my suggestion.

1) When you first start your macro, declare a variable and set it to NOW + 20 minutes.

Code:

    t = Now() + TimeValue("00:20:00")
    mytime = Format(t, "hh:mm:ss AMPM")

2) Your code has several "loops" in it where you're doing stuff, inside the loops include a timecheck to see if time is up.

Code:

   If Now > mytime Then 
      MsgBox "Time exceeded, no match found"
      Exit Sub
   End if

hi,

My request for you to re-upload the complete file (including the code - as part of the file) was because the uploaded file in post # 5 only appears to contain results not the initial information/layout which exists in your other thread. (I'm here, based on the other thread, to see if I could help optimise your code so that an Over-ride Timer (the subject of this thread) wouldn't be needed at all.)

We are more likely to be able give a complete answer when there is a more complete framework, rather than trying to put everything together from different sources/posts. If you would like me to try & help, can you please upload a new sample file including:
1) raw data with headers on each sheet to provide context,
2) your latest code (as part of the file rather than in the thread) &
3) expected results with some brief explanation of the necessary logic?

Thanks
Rob

hi Bgunawan,

I'm sorry I was mistaken, after looking at the code you have provided in the sample file of post #11 (after a rough Babelfish translation for the comments ) I don't think I will be able to optimise it much (although I'll try...). This code is definitely written rather than recorded & may help me learn as I play.

- Goodluck with your development

Btw, I could easily improve the speed of the macro code that you posted in the other thread, which I guess is effectively the manipulation/preparation macro to get your extract into the format for running the "FinalSubset" macro of this thread. If you would like help optimising the preparation macro, feel free to start a new thread with the sample file & then p.m. me a link to the thread.

Rob