The correct position to place msgbox in code

**Jim28** · 10-23-2011, 06:58 AM

Dear all

I am running the below code which searches for combinations of values that add up to a given target. Depending on the number of values it is searching through, the time it takes obviously goes up.

Option Explicit

Function RealEqual(a, b, Optional Epsilon As Double = 0.00000001)
    RealEqual = Abs(a - b) <= Epsilon
    End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
    If CurrRslt = "" Then ExtendRslt = NewVal _
    Else ExtendRslt = CurrRslt & Separator & NewVal
    End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
        ByVal HaveRandomNegatives As Boolean, _
        ByVal CurrIdx As Integer, _
        ByVal CurrTotal, ByVal Epsilon As Double, _
        ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
    
     Dim i As Integer
        For i = CurrIdx To UBound(InArr)
        If RealEqual(CurrTotal + InArr(i), TargetVal, Epsilon) Then
            Rslt(UBound(Rslt)) = (CurrTotal + InArr(i)) _
                & Separator & Format(Now(), "hh:mm:ss") _
                & Separator & ExtendRslt(CurrRslt, i, Separator)
            If MaxSoln = 0 Then
                If UBound(Rslt) Mod 100 = 0 Then Debug.Print "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))
            Else
                If UBound(Rslt) >= MaxSoln Then Exit Sub
                End If
            ReDim Preserve Rslt(UBound(Rslt) + 1)
        ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(i) > TargetVal + Epsilon) Then
        ElseIf CurrIdx < UBound(InArr) Then
            recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
                i + 1, _
                CurrTotal + InArr(i), Epsilon, Rslt(), _
                ExtendRslt(CurrRslt, i, Separator), _
                Separator
            If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
        Else
            'we've run out of possible elements and we _
             still don't have a match
             
            End If
   
        Next i
        
    End Sub
Function ArrLen(Arr()) As Integer
    On Error Resume Next
    ArrLen = UBound(Arr) - LBound(Arr) + 1
    End Function
Function checkRandomNegatives(Arr) As Boolean
    Dim i As Long
    i = LBound(Arr)
    Do While Arr(i) < 0 And i < UBound(Arr): i = i + 1: Loop
    If i = UBound(Arr) Then Exit Function
    Do While Arr(i) >= 0 And i < UBound(Arr): i = i + 1: Loop
    checkRandomNegatives = Arr(i) < 0
    End Function
Sub startSearch()
    'The selection should be a single contiguous range in a single column. _
     The first cell indicates the number of solutions wanted.  Specify zero for all. _
     The 2nd cell is the target value. _
     The rest of the cells are the values available for matching. _
     The output is in the column adjacent to the one containing the input data.
     
    'Range("B352").Select
    'Range(Selection, Selection.End(xlUp)).Select
    
    If Not TypeOf Selection Is Range Then GoTo ErrXIT
    If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
    If Selection.Rows.Count < 3 Then GoTo ErrXIT
    
    
    
    Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
        HaveRandomNegatives As Boolean
    StartTime = Now()
    MaxSoln = Selection.Cells(1).Value
    TargetVal = Selection.Cells(2).Value
    InArr = Application.WorksheetFunction.Transpose( _
        Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
    HaveRandomNegatives = checkRandomNegatives(InArr)
    If Not HaveRandomNegatives Then
    ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
                & vbNewLine _
            & "It may take a lot longer to search for matches." & vbNewLine _
            & "OK to continue else Cancel", vbOKCancel) = vbCancel Then
        Exit Sub
        End If
    ReDim Rslt(0)
    recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
        LBound(InArr), 0, 0.00000001, _
        Rslt, "", ", "
    Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
    ReDim Preserve Rslt(UBound(Rslt) + 1)
    Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
    Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
        Application.WorksheetFunction.Transpose(Rslt)
    Exit Sub
ErrXIT:
    MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
        & "The selection should be a single contiguous range in a single column." & vbNewLine _
        & "The first cell indicates the number of solutions wanted.  Specify zero for all." & vbNewLine _
        & "The 2nd cell is the target value." & vbNewLine _
        & "The rest of the cells are the values available for matching." & vbNewLine _
        & "The output is in the column adjacent to the one containing the input data."
    End Sub

When the code is searching through about 30 or more values excel comes up with the message (not responding).

I am not sure whether the code has crash or is still in fact running.

To test this I wish to place a temporary message box to appear, perhaps using the below code. I wish the message box to pop up once every minute for a few seconds to prove the code is still running.

   Dim message As Object     Set message = CreateObject("WScript.Shell")     message.Popup "This message will show for 1 seconds", 1, "Quick Message"

However I can not work out where to place it in the original code.

Can anyone help?

Many thanks in advance,

Jim

**TMS** · 10-23-2011, 07:11 AM

I haven't looked at your code but you're better putting Debug.Print in the code at a few strategic points. That won't interrupt the flow of the code and it will give you a "heartbeat" to prove the code is still running.

For example:

Debug.Print NOW(), variable 1 value, variable 2 value, etc

Either put the code in an "outer loop" so it only gets executed every so often, or put a loop counter in and print every 50 or 100 loops and clear the loop counter

Also, to speed up your code, consider using Application.ScreenUpdating and Application.Calculation to switch these off an on before and after executing code.

Regards

**Jim28** · 10-23-2011, 07:25 AM

Thanks very much TMShucks for your speedy response - apologises I have not come across the debug.print method before and do understand the variable1 value etc part.

Could you explain a bit more about what I need to put? I can do the counter part though...

**6StringJazzer** · 10-23-2011, 10:20 AM

I don't understand what your code is trying to do, but I see that you are using recursion, rather than a loop. I have added a counter to measure the depth of the recursion. It uses Debug.Print to print the depth of recursion every time the recursive Sub is entered and exited. I can't figure out how to get it to enter more than once, though.

To see the results of Debug.Print, go to your code and press CTRL+G to open the Immediate Window, where this output goes. You can clear out the Immediate window manually by hitting CTRL+a then DELETE or CTRL+x.

When running macros and getting "(Not Responding)" it is almost always because your code is in a long (possibly infinite) loop. If your recursion is going very deep, you may not want to print a message for each entry. You could do this to print for every multiple of 10 entries:

'''''''''' debug
If matchDepth Mod 10 = 0 Then
   Debug.Print "Entering recursiveMatch, depth=" & matchDepth
End If
matchDepth = matchDepth + 1
'''''''''' end debug

However, recursive calls allocate additional memory (stack space) on each call. If you are getting very deep calls then you would be likely to get an "out of memory" error eventually.

Are you interrupting the code when it seems to take a long time?

**Jim28** · 10-23-2011, 11:02 AM

Hi

The only thing I can do is do ctrl pause break to get back into the macro when it stops responding.

I really want to stop this happening and thought a message box popping up intermittantly might do this....

**6StringJazzer** · 10-23-2011, 12:20 PM

The message box won't allow you to stop, unless you put an Exit Sub in there based on the response to the box.

If you can tell me exactly what data you use and how you run it, I can try to reproduce it and help diagnose the problem. But I selected all of the data in column B and it ran instantly.

**6StringJazzer** · 10-23-2011, 12:41 PM

OK, I see what you are trying to do but I don't have time to thoroughly analyze your code. I waited until the recursive Sub had been executed 115,000 times before I interrupted it. Your code is not crashing.

It is possible that there is nothing at all wrong with your code. To evaluate all combinations of n numbers, you have to do this many comparisons

sum of n!/r!(n-r)! for r=1 to n

For 30 numbers, that's about a billion combinations. That could take Excel a while.

You may also find this related thread helpful, or at least interesting.