Program running 4 times instead of once, Work around?

**MGARDNER** · 07-18-2013, 05:57 PM

Hi Guys, I'm new to the forum so please excuse me if I mess anything up.

I'm wondering how to get a certain program to only run once? The following code continues to loop 4 times which is a nuisance due to various pop up msgboxs. Any ideas?

Private Sub Worksheet_Change(ByVal Target As Range)
    Static SheetBusy As Boolean

    If SheetBusy Then
        Exit Sub
    End If

    'Prevent the subroutine from looping
    SheetBusy = True

    ' Perform Calculations
    RG
    UNDERDRAIN
    ' Set the error handler
    On Error GoTo bail

    ' Select the radio buttons
    SelectRadioButtons

bail:

SheetBusy = False
On Error GoTo 0
End Sub

Sub RG()
Application.ScreenUpdating = False

On Error Resume Next
Sheets("RG").Activate

if XXX <>"" then
do something
display outputs
else 
clear outputs
end if
Application.ScreenUpdating = True
End Sub

Sub UNDERDRAIN()
Application.ScreenUpdating = False

On Error Resume Next
Sheets("RG").Activate

if XXX <>"" then
do something
display outputs
else 
clear outputs
end if
Application.ScreenUpdating = True
End Sub

The second issue is that each time the user updates any of the radio buttons, the program will re perform all the calculations. Is there any way to ignore certain button selections in the worksheet_change sub?

Thanks in advance.
-Myles

**MGARDNER** · 07-20-2013, 05:06 PM

BUMP, Anyone? Is there not enough info?

**Norie** · 07-20-2013, 05:25 PM

Myles

I don't think you've posted all the code.

In what you have posted other subs are being called, and those subs call other subs.

There could be code in any of those subs that is changing the worksheet, and therefore triggering the change event.

If that is the problem what you could do is add this in the Change event just before you call the other subs.

Application.EnableEvents = False

If you do use that it's important to enable events again:

Application.EnableEvents = True

**MGARDNER** · 07-23-2013, 02:58 AM

Thank you very much, I was able to use the enableevents to get it to correctly run the first time, but if user updates after the initial run, noting happens. Am I using this correctly?

Here is what I have so far:

Private Sub Worksheet_Change(ByVal Target As Range)
    Static SheetBusy As Boolean

    If SheetBusy Then
        Exit Sub
    End If

    'Prevent the subroutine from looping
    SheetBusy = True

    ' Perform Calculations
    'Application.EnableEvents = False
    RG
    UNDERDRAIN
    
    ' Set the error handler
    On Error GoTo bail

    ' Select the radio buttons
    SelectRadioButtons
    'Application.EnableEvents = True
bail:

SheetBusy = False
On Error GoTo 0
End Sub
Sub options()
    SelectRadioButtons
End Sub
Private Function SelectRadioButtons()
    Dim targetButton As Shape
    Dim targetbuttons As Shape
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
'Leave Impermable layer option buttons blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 2")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 13")
        targetButton.DrawingObject.Value = False
    End If

'Leave Inlet/Outlet Control Check Boxes blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 77")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 78")
        targetButton.DrawingObject.Value = False
    End If
    
'Leave Growing Media option buttons blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 5")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 6")
        targetButton.DrawingObject.Value = False
    End If
    
'Leave Underdrain System option buttons blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 28")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 29")
        targetButton.DrawingObject.Value = False
    End If

'Leave Plant Selection option buttons blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 100")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 101")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 102")
        targetButton.DrawingObject.Value = False
    End If
    
'Leave Planting option buttons blank initially
    If Range("RGIA").Value = "" Then
        Set targetButton = Shapes("Option Button 106")
        targetButton.DrawingObject.Value = False
        Set targetButton = Shapes("Option Button 105")
        targetButton.DrawingObject.Value = False
    End If

'Flag Geotextile Separator
Set targetButton = Shapes("Option Button 2")
If targetButton.DrawingObject.Value = 1 Then
Range("RG23").Value = "PROVIDE A 30 MIL (MIN) PVC LINER WITH CDOT CLASS B"
Range("RG24").Value = "GEOTEXTILE ABOVE IT.  USE THE SAME GEOTEXTILE BELOW THE"
Range("RG25").Value = "LINER IF THE SUBGRADE IS ANGULAR"
Else:
Range("RG23").ClearContents
Range("RG24").ClearContents
Range("RG25").ClearContents
End If

'Flag if there is irrigation
Set targetButton = Shapes("Option Button 105")
    If targetButton.DrawingObject.Value = 1 Then
        Range("RGIFLAG").Value = "NO SPRINKLER HEADS ON THE FLAT SURFACE"
    Else:
        Range("RGIFLAG").ClearContents
    End If

Application.ScreenUpdating = True
'Application.enableevents=true

End Function

Sub RG()
Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
Sheets("RG").Activate

'Assigns low limit to value "Ia" entered in cell "RGIA"
If Range("RGIA").Value = "" Then
ElseIf Range("RGIA").Value < 0 Or Range("RGIA").Value > 100 Then
    Range("RGIA").ClearContents
ElseIf Range("RGIA").Value < 1 Then
    Range("RGIA").Value = Range("RGIA").Value * 100
End If
'Assigns low limit to contributing watershed area in cell "RGA"
If Range("RGA").Value = "" Then
ElseIf Range("RGA").Value < 0 Then
    Range("RGA").ClearContents
End If

'Assigns low limit to side slopes horizontal
If Range("RGZ").Value = "" Then
ElseIf Range("RGZ").Value < 0 Then
    Range("RGZ").ClearContents
End If

'Flag side slopes
If Range("RGZ").Value = "" Or Range("RGZ").Value = 0 Then
Range("RGZFLAG").ClearContents
ElseIf Range("RGZ").Value > 0 And Range("RGZ").Value < 4 Then
Range("RGZFLAG").Value = "Z < 4:1"
Else:
Range("RGZFLAG").ClearContents
End If

'Assigns low limit to bottom surface area in cell "RGACCT"
If Range("RGACCT").Value = "" Then
ElseIf Range("RGACCT").Value < 0 Then
    Range("RGACCT").ClearContents
End If

'Assigns low limit to depth of WQCV in cell "RGDWQ"
If Range("RGDWQ").Value = "" Then
ElseIf Range("RGDWQ").Value < 0 Then
    Range("RGDWQ").ClearContents
End If

If Range("RGLW") <> "" And Range("RGW") <> "" Then
    MsgBox "Enter either Rain Garden Width OR Rain Gardens Length to Width raito, not both!", vbCritical, "Input Error"
    Range("RGW").ClearContents
    Range("RGLW").ClearContents
    Range("RGW").Select
End If

If Range("Counta") = 8 Then
    RGVOLI = RGWQCVUI * RGA / 12
    RGAMIN = RGVOLI / (RGDT * RGVI / 12)
    If Range("RGAACT") = "" Then
        AMIN = RGAMIN
    Else
        If Range("RGAACT") < 0 Then
            MsgBox "Minimum surface area has to be greater then zero square feet!", vbExclamation, "Error"
            Range("RGVOLI").ClearContents
            Range("RGATOP").ClearContents
            Range("RGLT").ClearContents
            Range("RGWT").ClearContents
            Range("AMIN").ClearContents
            Range("DWQCV").ClearContents
            Range("RGL").ClearContents
            Range("_RGW").ClearContents
            Exit Sub
        ElseIf Range("RGAACT") < RGAMIN Then
            MsgBox "User specified surface area is less then the calculated minimum. Area set to calculated minimum area", vbExclamation, "Caution"
            AMIN = RGAMIN
        Else
            RGAACT = Range("RGAACT")
            AMIN = RGAACT
        End If
    End If
    If RGW = "" Then
        RGW = (AMIN / RGLW) ^ 0.5
    End If
    RGL = AMIN / RGW
    DWQCV = 0.1
    WQCVC = 0
    Do While WQCVC < RGVOLI
        'Calculations are here...
        If WQCVC >= RGVOLI Then
        ElseIf (WQCVC / RGVOLI) < 0.75 Then
            DWQCV = DWQCV + 0.2
        ElseIf (WQCVC / RGVOLI) < 0.9 Then
            DWQCV = DWQCV + 0.1
        Else
            DWQCV = DWQCV + 0.01
        End If
    Loop
    If DWQCV > (RGDWQ / 12) Then
        MsgBox "User specified surface area requires greater WQCV depth than the user specified maximum depth. Program completed", vbExclamation, "Caution"
        Range("RGVOLI") = RGVOLI
        Range("DWQCV") = DWQCV * 12
        Range("AMIN") = AMIN
        Range("RGATOP") = RGATOP
        Range("RGLT") = RGLT
        Range("RGWT") = RGWT
        Range("RGL") = RGL
        Range("_RGW") = RGW
        Exit Sub
    Else
        'MsgBox "Program Completed", vbInformation, "Completed"
        Range("RGVOLI") = RGVOLI
        Range("DWQCV") = DWQCV * 12
        Range("AMIN") = AMIN
        Range("RGATOP") = RGATOP
        Range("RGLT") = RGLT
        Range("RGWT") = RGWT
        Range("RGL") = RGL
        Range("_RGW") = RGW
    End If
Else:
    Range("RGVOLI").ClearContents
    Range("RGATOP").ClearContents
    Range("RGLT").ClearContents
    Range("RGWT").ClearContents
    Range("AMIN").ClearContents
    Range("DWQCV").ClearContents
    Range("RGL").ClearContents
    Range("_RGW").ClearContents
End If

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Sub UNDERDRAIN()

On Error Resume Next
Sheets("RG").Activate
Application.ScreenUpdating = False
Applicantion.EnableEvents = False


Set targetButton = Shapes("Option Button 28")
If Range("COUNTA") = 8 And Range("DWQCV") <> "" And targetButton.DrawingObject.Value = 1 And Range("RGHWQCV") > 0 Then 'Initiate Calculations
    'Calculations are here...
    Range("RGDO") = RGDO
    'If Range("RGDT2") = "" Then
        RESPONSE = MsgBox("Do you want to use the nearest nominal size?", vbQuestion + vbYesNo, "Nominal Size?") 'option to use nominal sizes
    'Else
    'End If
    If RESPONSE = vbYes Then 'if yes then finds nearest nominal sizes and selects the most accurate size
        RGDON = 1 / 4 'Minimum orfice diameter
        Do While RGDON < RGDO
            RGDON = RGDON + 1 / 32
        Loop
        'Calculations are here...
        If ERP < ERM Or RGDONP = 0.25 Then 'Shows user which size is most accurate
            Range("RGDO") = RGDONP
            Range("RGDT2") = RGTP / 3600
        ElseIf ERM < ERP Then
            Range("RGDO") = RGDONM
            Range("RGDT2") = RGTM / 3600
            
        End If
    End If
    If RESPONSE = vbNo Then 'Displays original Drain time
        Range("RGDT2") = Range("RGDT")
    End If
Else: 'Clears outputs if nothing is entered
    Range("RGDO").ClearContents
    Range("RGDT2").ClearContents
End If

'Set targetButton = Shapes("option Button 29")
'If targetButton.DrawingObjects.Checked = True Then
'    Range("RGDO").ClearContents
'    Range("RGDT2").ClearContents
'End If

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Thank you very very much for the help!
-Myles

Program running 4 times instead of once, Work around?

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Program running 4 times instead of once, Work around?

Re: Program running 4 times instead of once, Work around?

Re: Program running 4 times instead of once, Work around?

Re: Program running 4 times instead of once, Work around?

Thread Information

Users Browsing this Thread

Similar Threads

vba program - before and after times

Excel VBA program times out

Button program macro (times a pct)

program running too slow

[SOLVED] how do i program excel to add two times together

Bookmarks

Bookmarks

Posting Permissions