Run code after set period of time

E

EssKayKay

Active Member
Joined
Jan 5, 2003
Messages
407
Office Version
  1. 2007
Platform
  1. Windows
Hello,
I’m not sure this is even possible but I’ll start here.

I have a routine (cmdPmtMade_Click) that for the most part works fine. However, as the routine is run numerous times the whole process begins to slow down. Over time, what initially takes a couple seconds to run can progress to nearly a minute. I have tried to see what is causing this but was unsuccessful in my review.

I have a second routine that basically copies all the data from one worksheet to another then re-saves the file under the original name. After running this “Repair” sub, the “PmtMade” sub (and others) works great for awhile until it again begins to slow down. If I rerun the REPAIR, all is fine again for some time.

What I was thinking of is some way that if the original routine (PmtMade) takes more that X number of seconds, a message box would appear prompting the user to run the “Repair” routine to speed up the process.

So, my question – Is there some command that when “PmtMade” button is clicked after a specified time (say 10 seconds), will trigger some other code or message box ? I tried Application.OnTime but could not get that to work (I probably had something set wrong).

Thanks for viewing,
Steve K.
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
It sounds like maybe an Object may not be getting killed after each use and is causing more use of memory. I would peruse over the code and make sure that there isn't a long living Object causing your program to slow.
 
Upvote 0
Thanks for getting back to me Skybot. I most certainly agree you are probably correct but I must note, I am not a programmer so after all my "looking" I suspect I would not be successful at such. That is why I would like to go the "message" route. I realize this is very poor programing or design but at this point it's the best I could do. Maybe the user(s) will just have to be made aware that if the program slows down significantly they can try running my REPAIR routine which in many instances does help.

Again, much appreciated,
Steve K.
 
Upvote 0
Sure, I can provide the code, But it is VERY convoluted and I suspect a bit overwhelming.

There are numerous routines in my entire project. As an example, here is the one I was addressing. You will see there are other routines being called (although I do not use the “call” command”) – and in the calls, there are other calls. I know – pretty sad.

I must stress again, I am not a programmer. Therefore, I suspect when you look my code you will be disgusting amazed at how sloppy it is. The only thing I can say is that for the most part – it works.


VBA Code: 
Private Sub cmdPmtMade_Click()

If Sheets("Amortize").Columns(17).Hidden = False Then 'MsgBox "Visible"
Range("A4,H5").Select
Range("H5").Activate
End If

Application.ScreenUpdating = False
Application.EnableEvents = True

Range("OneTime") = "---"
Range("TempCell") = "Pmt_Made"

Call OneTimePmt1
Call OneTimePmt2

If Range("F6") <= 0 Or Range("F7") <= 0 Or Range("F8") <= 0 Or Range("F10") <= 0 Then
  MsgBox " Missing Loan Information." & vbNewLine & _
  " Enter Loan Info criteria. . .", , " - Loan Info -"
  If Range("F10") = "" Then Range("F10").Select
  If Range("F8") = "" Then Range("F8").Select
  If Range("F7") = "" Then Range("F7").Select
  If Range("F6") = "" Then Range("F6").Select
Protect_It
Exit Sub
End If

'======== Added 0/06/24 ==========
If Range("M34") > 0 Then Formulas2Values '<=== check this for editing
  PaymentSetup
  UpdateOneTimePmt
  ResetPITI
  OneTimeDATE
Range("M31").End(xlDown).Offset(1, 0).Select

'--- Set selected Pmt_Date at screen center ---
If Range("M45") > 0 Then
  If ActiveCell.Row > 13 Then ActiveWindow.ScrollRow = ActiveCell.Row - 13
     Range("M2035").End(xlUp).Offset(1, 0).Select
  End If

UnProtect_It
Range("F29").ClearContents
Range("F29") = "Ready"
Application.EnableEvents = True
Application.ScreenUpdating = true

End Sub

Code: 
Sub OneTimePmt1()
'================ Based on MUMP's Code =================
' --- For One-Time Pmt w/no date or amt (coded SKK) ---
' --------- Must be run BEFORE OneTimePmt2 ---------


Dim x As Long
For x = 8 To 12 Step 2
If Range("K" & x) = "" Then
  Range("K" & x + 1).Select
  UnProtect_It

  With Range("K" & x + 1)
    .Locked = True
    .Interior.Color = 15984868
  End With

  Range("C2").Select
End If
Next x
End Sub



Code: 
Sub OneTimePmt2()

'============ Based on MUMP's Code ==============
' ---- For One-Time Pmt if only date/no amt ----
' ------ Must be run AFTER OneTimePmt1 -------

Dim y As Long
For y = 8 To 12 Step 2
If Range("K" & y & ":K" & y + 1).Locked = False And Range("K" & y + 1) = "" Then
  MsgBox " Missing One-Time AMOUNT" & vbNewLine & _
  " Re-enter Payment details.", , " One-Time Pmt."

  Application.ScreenUpdating = True
  Range("A4,H5").Select
  Application.ScreenUpdating = False
  Range("K" & y + 1).Select
  UnProtect_It
  End
End If

Next y
End Sub

Code: 
Sub Formulas2Values() '- Convert Formulas to Values -
Application.ScreenUpdating = False '<=== May need to be True? ===
Dim OrgCell As Range
Set OrgCell = ActiveCell
Range("M32:M2032").Select
Sheets("Amortize").Select
ActiveSheet.Unprotect
Selection.Locked = False
OrgCell.Select

Range("M32").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Range(Selection, Selection.End(xlToLeft).Offset(0, 1)).Select

Sheets("Amortize").Select
ActiveSheet.Unprotect
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

'. . . . . . . . . . . . . . . . . . . . . .
Range("K32").Select
ActiveCell.FormulaR1C1 = "=loan_amount"
Range("C2").Select


'-------- Convert PITI Formulas --------
' . . . . First - Mo.Pmt & Year . . . .
Dim lr&, SLr
lr = Range("M" & Rows.Count).End(xlUp).Row
UnProtect_It
Range("Q33:R" & lr).Value = Range("Q33:R" & lr).Value
Range("R33:R133").Value = Range("R33:R133").Value

' . . . . Second - Year Amount . . . .
Dim Row As Long
' Look for non-blank cells in column T starting at row 33
Row = 33
Do Until Cells(Row, "T").Value = ""

' If the corresponding cell in columns S is a formula, convert to a value
If Left(Cells(Row, "S").Formula, 1) = "=" Then
Cells(Row, "S").Value = Cells(Row, "S").Value
End If
Row = Row + 1
Loop
'---------------------------------------
End Sub


Code: 
Private Sub PaymentSetup()
Application.ScreenUpdating = False

Range("C2").Select
UnLock_M
UnProtect_It

'====== Set Heading Color =======
UnProtect_It
Range("M31").Font.Color = 192
'================================

Columns("N:O").Hidden = False
ActiveSheet.Shapes("Print Shape").Visible = False

  Sheets("Amortize").cmdControlCenter.Visible = False
  Sheets("Amortize").cmdAddPayment.Visible = False
  Sheets("Amortize").cmdPmtMade.Visible = False
  Sheets("Amortize").cmdHome.Visible = True

Dim btn As Shape
Set btn = ActiveSheet.Shapes("cmdTitle")
btn.Width = 554
  ActiveSheet.Shapes("Title Shape").Width = 564

  Rows("4:28").EntireRow.Hidden = True
  Rows("32:32").Select

  ActiveWindow.FreezePanes = False
  ActiveWindow.FreezePanes = True

  Range("M31").End(xlDown).Offset(1, 0).Select

  UnProtect_It
  If Range("M33") > 0 And Range("M34") = "" Then
    ResetFirstPmt
    Exit Sub
   End If

  Protect_It
  Application.ScreenUpdating = True
End Sub

Code: 
Sub UpdateOneTimePmt()
Application.ScreenUpdating = False
UnProtect_It

If Application.WorksheetFunction.Sum(Range("K8:K13")) <= 0 Then
Exit Sub
Else

'===== Update OneTime #1 =====
Range("K6:K13").Select
Selection.Locked = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
End With

If Range("K8").Locked = False Then
If Range("K8") > 0 And Range("K9") > 0 Then
UnProtect_It
Range("K8,K9,K11:K13").Select
Selection.Locked = True
Selection.FormulaHidden = False
With Selection.Interior
.Color = 15984868
.TintAndShade = 0
End With
End If
End If

'===== Update OneTime #2 =====
If Range("K10").Locked = False Then
If Range("K10") > 0 And Range("K11") > 0 Then
UnProtect_It
Range("K8:K13").Select
Selection.Locked = True
Selection.FormulaHidden = False
With Selection.Interior
.Color = 15984868
.TintAndShade = 0
End With

Range("K12").Select
UnProtect_It
Selection.Locked = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
End With

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False

Range("M31").End(xlDown).Offset(1, 0).Offset(0, 1).Offset(0, -1).Select
Else
Range("M31").End(xlDown).Offset(1, 0).Select
Exit Sub
End If

End If        '<--- this may not be where this End If should be (see below)? ---

'===== Update OneTime #3 =====
If Range("K11").Locked = True And Range("K12") > 0 And Range("K13") > 0 Then
UnProtect_It
Range("K8:K13").Select
Selection.Locked = True
Selection.FormulaHidden = False
With Selection.Interior
.Color = 15984868
.TintAndShade = 0
End With
Else
Application.ScreenUpdating = True
End If
End If

UnProtect_It
Range("K33:K2032").SpecialCells(xlCellTypeFormulas, 23)(1).Offset(, 2).Select

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Protect_It
End Sub


Code: 
Public Sub ResetPITI()
Application.ScreenUpdating = False

Range("S33").Formula = Replace("=IF(SUMPRODUCT(--(YEAR($C$32:$C$#)=R33),$Q$32:$Q$#)>0,SUMPRODUCT(--(YEAR($C$32:$C$#)=R33),$Q$32:$Q$#),"""")", "#", Range("T13").Value)

'. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
Range("S33").Copy
Range("S33:S" & Range("LastPmtRow").Value).Select
ActiveSheet.Paste
End Sub


Code: 
Sub OneTimeDATE()
Application.ScreenUpdating = False
Range("OneTime") = ""

  If Application.WorksheetFunction.Sum(Range("K8:K13")) <= 0 And Range("F6").Locked = True Then
    Range("OneTime") = "ONE"
  Else
    If Range("K8") > 0 And Range("K9") > 0 And Range("K10") <= 0 And Range("K11") <= 0 And Range("F6").Locked = True Then
      Range("OneTime") = "TWO"
    Else
       If Range("K8") > 0 And Range("K9") > 0 And Range("K10") > 0 And Range("K11") > 0 And _
          Range("K12") <= 0 And Range("K12") <= 0 And Range("F6").Locked = True Then
          Range("OneTime") = "THREE"
       Else
          If Range("K8") > 0 And Range("K9") > 0 And Range("K10") > 0 And Range("K11") > 0 And _
              Range("K12") > 0 And Range("K13") > 0 And Range("F6").Locked = True Then Range("OneTime") = "---"
          End If
      End If
    End If
End Sub


If you wish to pass on this I totally understand. If so, simply disregard this post.

Thank you for your interest, inquiry, and support,
Steve K.
 
Upvote 0
I see a lot of references to UnProtect_It. Can you share that subroutine?
 
Upvote 0
They protect and unprotect the worksheet. I don't know why the code display </> isn't working. I tried numerous times.

[CODE)
Sub UnProtect_It()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Unprotect
Next ws
End Sub
[/CODE]

[CODE)
Sub Protect_It()
Sheets("Amortize").Protect
End Sub
[/CODE]
 
Last edited:
Upvote 0
So far so good. Can I look at the Repair subroutine?
 
Upvote 0
I renamed Repair toe Refresh_ALL. I'm still having a problem trying to post the routine as "code".


VBA Code: 
Public Sub Refresh_ALL()
UnProtect_It

   Range("I33").Copy
   Range(Selection, Selection.End(xlDown)).Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Range("M33:M" & Range("LastDataRow").Value).Select
   Selection.ClearContents

   Range("F6:F8,F10,K6:K13,F15:F17,F22").ClearContents
   Range("F11").Select
   ActiveCell.FormulaR1C1 = "Monthly"
   Range("F12").Select
   ActiveCell.FormulaR1C1 = "Monthly"

'-----------------------------------------------
   Range("B" & Range("FormulasRow").Value & ":" & "K" & Range("FormulasRow").Value).Copy
   Range("B33:B" & Range("LastDataRow").Value).Select
   Range("B" & Range("LastDataRow").Value).Activate
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Range("B33").Select

'-----------------------------------------------

   Range("O33:O" & Range("LastDataRow").Value).ClearContents
'- - - - - - - - - - - - - - - - - - - - -

   Range("F6:F8,F10:F12").Select
   Selection.Locked = False
   Selection.FormulaHidden = False
   With Selection.Interior
      .Pattern = xlNone
      .TintAndShade = 0
   End With

'---- Freeze One-Time until all Info is added ----

   Range("F15:F17,F22,K6:K13").Select
   Selection.Locked = True
   Selection.FormulaHidden = False
   With Selection.Interior
      .Color = 15984868
      .TintAndShade = 0
   End With

   Range("K32").Select
   ActiveCell.FormulaR1C1 = "=loan_amount"
End Sub
 
Upvote 0
Paste this in the ThisWorkbook code module of your workbook (outside of any subroutines). Please make sure that you test on a copy of your workbook. This will run your Refresh_ALL code on the fifth time that the button is pressed.

VBA Code: 
Public x as Integer

Then replace Private Sub cmdPmtMade_Click code with this slightly modified version

VBA Code: 
Private Sub cmdPmtMade_Click()

ThisWorkbook.x = ThisWorkbook.x + 1 'This line and the following line were added to your original code

If ThisWorkbook.x = 5 Then Refresh_ALL   'This reference may need to change depending on code placement

If Sheets("Amortize").Columns(17).Hidden = False Then 'MsgBox "Visible"
Range("A4,H5").Select
Range("H5").Activate
End If

Application.ScreenUpdating = False
Application.EnableEvents = True

Range("OneTime") = "---"
Range("TempCell") = "Pmt_Made"

Call OneTimePmt1
Call OneTimePmt2

If Range("F6") <= 0 Or Range("F7") <= 0 Or Range("F8") <= 0 Or Range("F10") <= 0 Then
  MsgBox " Missing Loan Information." & vbNewLine & _
  " Enter Loan Info criteria. . .", , " - Loan Info -"
  If Range("F10") = "" Then Range("F10").Select
  If Range("F8") = "" Then Range("F8").Select
  If Range("F7") = "" Then Range("F7").Select
  If Range("F6") = "" Then Range("F6").Select
Protect_It
Exit Sub
End If

'======== Added 0/06/24 ==========
If Range("M34") > 0 Then Formulas2Values '<=== check this for editing
  PaymentSetup
  UpdateOneTimePmt
  ResetPITI
  OneTimeDATE
Range("M31").End(xlDown).Offset(1, 0).Select

'--- Set selected Pmt_Date at screen center ---
If Range("M45") > 0 Then
  If ActiveCell.Row > 13 Then ActiveWindow.ScrollRow = ActiveCell.Row - 13
     Range("M2035").End(xlUp).Offset(1, 0).Select
  End If

UnProtect_It
Range("F29").ClearContents
Range("F29") = "Ready"
Application.EnableEvents = True
Application.ScreenUpdating = true

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Macro runs more slowly each time it is run
2 3 4
Replies
34
Views
927
Jehannum_2000
J
E
  • Solved
Help speed up "change font color" routine
Replies
5
Views
212
EssKayKay
E
pcc
  • Solved
Why does a simple procedure take so long after conversion from .xls to .xlsm?
Replies
8
Views
178
pcc
pcc
T
  • Solved
Move cursor to a specific cell after data has been entered
Replies
4
Views
216
Peter_SSs
Peter_SSs
K
  • Question Question
VBA macro sometimes requires running twice to fully complete
Replies
6
Views
465
knittelmail
K

Forum statistics

Threads
1,223,912
Messages
6,175,341
Members
452,638
Latest member
Oluwabukunmi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top