I created a countdown timer in VBA from some code I found a while back. The issue is that if I duplicate the timer to use on a different slide, they are both linked and will both start at the same time. This means that when I pause the timer on one slide, it becomes the starting point of the next.
I'm wanting to know what the simplest way is of duplicating my timer where each one is independent of the others. I'm looking to have around 10 timers on 10 different slides.
I've tried copying and pasting the timer, then changing the shape names in the selection panel which the code pulls on as the action buttons. This didn't work the way I thought it would.
I thought about just changing the macros names and then linking it to the new timer. But I couldn't find any macros attached to any of the timer's buttons.
Here is a file with the timer: Timer Powerpoint
(Note: Only 1 timer will work on one slide at a time, so place any duplicate on a different slide. Open in ppt not google slides.)
Any help with this would be amazing.
CODE:
`
Option Explicit
Global timeLeft As Date
Global updateTimer As Boolean
Global timerRunning As Boolean
Global changeTimerbyValue
Global currentTimerSlide As Integer
Global pauseTimer As Boolean
Sub countdownTimer()
On Error Resume Next
Dim thisSlide As Slide
Dim currentSlide As Integer
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
For Each thisSlide In ActivePresentation.Slides
thisSlide.Shapes("PauseTimer").Visible = True
thisSlide.Shapes("StartTimer").Visible = False
thisSlide.Shapes("EndBackground").Visible = False
thisSlide.Shapes("MainBackground").Visible = True
Next thisSlide
updateTimer = False
timerRunning = True
Dim seconds As Integer
seconds = ActivePresentation.Slides(currentSlide).Shapes("seconds").TextFrame.TextRange
Dim minutes As Integer
minutes = ActivePresentation.Slides(currentSlide).Shapes("minutes").TextFrame.TextRange
Dim hours As Integer
hours = ActivePresentation.Slides(currentSlide).Shapes("hours").TextFrame.TextRange
Dim time As Date
time = hours & ":" & minutes & ":" & seconds
Dim currentTime As Date
currentTime = Now()
Dim timerTime As Date
timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
pauseTimer = False
Do Until timerTime < Now()
DoEvents
If (updateTimer = True) Then
timerTime = DateAdd("s", changeTimerbyValue, timerTime)
updateTimer = False
End If
timeLeft = timerTime - Now()
For Each thisSlide In ActivePresentation.Slides
thisSlide.Shapes("hours").TextFrame.TextRange = Format(timeLeft, "hh")
thisSlide.Shapes("minutes").TextFrame.TextRange = Format(timeLeft, "nn")
thisSlide.Shapes("seconds").TextFrame.TextRange = Format(timeLeft, "ss")
Next thisSlide
If (pauseTimer) Then
pauseTimer = False
timerRunning = False
Exit Do
End If
Loop
timerRunning = False
For Each thisSlide In ActivePresentation.Slides
thisSlide.Shapes("PauseTimer").Visible = False
thisSlide.Shapes("StartTimer").Visible = True
Next thisSlide
ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = False
ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = True
If (timerTime < Now()) Then
For Each thisSlide In ActivePresentation.Slides
thisSlide.Shapes("hours").TextFrame.TextRange = Format(0, "hh")
thisSlide.Shapes("minutes").TextFrame.TextRange = Format(0, "nn")
thisSlide.Shapes("seconds").TextFrame.TextRange = Format(0, "ss")
Next thisSlide
ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = True
ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = False
Beep
Call AppWait
Beep
Call AppWait
Beep
Call AppWait
ActivePresentation.Slides(currentSlide).Shapes("EndBackground").Visible = False
ActivePresentation.Slides(currentSlide).Shapes("MainBackground").Visible = True
End If
End Sub
Sub hitPause()
pauseTimer = True
Dim currentSlide As Integer
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
End Sub
Sub changeTime(ByVal theTime As Integer)
On Error Resume Next
Dim currentSlide As Integer
Dim thisSlide As Slide
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
If (currentTimerSlide <> currentSlide And currentTimerSlide <> 0 And timerRunning = True) Then
pauseTimer = True
Exit Sub
End If
Dim currentTime As Date
currentTime = Now()
Dim seconds As Integer
seconds = ActivePresentation.Slides(currentSlide).Shapes("seconds").TextFrame.TextRange
Dim minutes As Integer
minutes = ActivePresentation.Slides(currentSlide).Shapes("minutes").TextFrame.TextRange
Dim hours As Integer
hours = ActivePresentation.Slides(currentSlide).Shapes("hours").TextFrame.TextRange
If (timerRunning = True) Then
If (theTime = -3600 And hours = 0) Then
'Do nothing
ElseIf (theTime = -60 And hours = 0 And minutes = 0) Then
'Do nothing
Else
changeTimerbyValue = theTime
updateTimer = True
End If
End If
If (timerRunning = False) Then
Dim time As Date
time = hours & ":" & minutes & ":" & seconds
Dim timerTime As Date
If (theTime = -3600 And hours = 0) Then
timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
ElseIf (theTime = -60 And hours = 0 And minutes = 0) Then
timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
Else
timerTime = DateAdd("s", seconds + 60 * minutes + 3600 * hours + 0.99, currentTime)
timerTime = DateAdd("s", theTime, timerTime)
End If
timeLeft = timerTime - Now()
For Each thisSlide In ActivePresentation.Slides
thisSlide.Shapes("hours").TextFrame.TextRange = Format(timeLeft, "hh")
thisSlide.Shapes("minutes").TextFrame.TextRange = Format(timeLeft, "nn")
thisSlide.Shapes("seconds").TextFrame.TextRange = Format(timeLeft, "ss")
Next thisSlide
End If
End Sub
Sub increaseSeconds()
changeTime (1)
End Sub
Sub decreaseSeconds()
changeTime (-1)
End Sub
Sub increaseMinutes()
changeTime (60)
End Sub
Sub decreaseMinutes()
changeTime (-60)
End Sub
Sub increaseHours()
changeTime (3600)
End Sub
Sub decreaseHours()
changeTime (-3600)
End Sub
Sub startTimer()
If (timerRunning = False) Then
Call countdownTimer
End If
End Sub
Sub AppWait()
Dim WAIT As Double
WAIT = Timer
While Timer < WAIT + 0.75 ' 1 seconds
DoEvents 'do nothing
Wend
End Sub
`
You can duplicate timelimit and countdown objects on each slide you need. Just make sure those objects have exactly the same names. Then, you can get the active slide in a Loop. On activating another slide, the countdown object on that slide will be updating.
Something like this:
Sub countdown()
Dim activeSlide As Slide
Dim count As Integer
Dim tstart As Date
Dim tend As Date
tstart = Now()
Do While True
DoEvents
Set activeSlide = _
PowerPoint.Application.ActiveWindow.View.Slide
count = activeSlide.Shapes("timelimit").TextFrame.TextRange
tend = DateAdd("n", count, tstart)
activeSlide.Shapes("countdown").TextFrame.TextRange = _
Format((tend - Now()), "nn:ss")
If tend < Now() Then
activeSlide.Shapes("countdown").TextFrame.TextRange = "TIME UP"
End If
Loop
End Sub
Related
This is my first time ever programming something and I have managed to create a macro for a live clock on a Powerpoint (2016) presentation. The macro works perfectly, activating on my designated named slide only. However, I cannot find a way to interrupt the "Do Until clock=false" loop so that the presentation can advance to the next slide. The idea is for the presentation to be on a continuous loop so I need to macro to stop after the designated slide to avoid any lagging when cycling through.
I have tried to include a timevalue function to add a time onto the current time and give a place to stop, but this seems to have no effect.
Any help would be much appreciated!
Public clock As Boolean
Private Sub Pause()
Dim PauseTime, start
PauseTime = 1
start = Timer
Do While Timer < start + PauseTime
DoEvents
Loop
End Sub
Sub OnSlideshowPageChange(Wn As SlideShowWindow)
Dim currenttime, currenttimecount As Date
Dim currentdate, currentday As String
If Wn.View.Slide.Name = "autoclock 1" Then clock = True
Do Until clock = False
On Error Resume Next
If Weekday(Now) = 1 Then currentday = "Sunday"
If Weekday(Now) = 2 Then currentday = "Monday"
If Weekday(Now) = 3 Then currentday = "Tuesday"
If Weekday(Now) = 4 Then currentday = "Wednesday"
If Weekday(Now) = 5 Then currentday = "Thursday"
If Weekday(Now) = 6 Then currentday = "Friday"
If Weekday(Now) = 7 Then currentday = "Saturday"
currentdate = FormatDateTime(Now, vbLongDate)
currenttime = FormatDateTime(Now, vbLongTime)
currenttimecount = currenttime + TimeValue("00:00:10")
If currenttime = currenttimecount Then clock = False
If clock = False Then SlideShowWindows(1).View.Next
activepresentation.Slides(SlideShowWindows(1).View.CurrentShowPosition).Shapes("shpDayClockAuto").TextFrame.TextRange.Text = currentday & Space(20) & currentdate & Space(15) & currenttime
Pause
Loop
End Sub
Private Sub OnSlideshowTerminate(SW As SlideShowWindow)
clock = False
End Sub
I have a PowerPoint which begins with a a media file automatically playing. The first slide is programmed to transition after 20 seconds, all the while the music keeps playing. I would like for it to keep playing for the duration of the slideshow, but fade to a lower volume once the second slide appears and remain that way for the rest of the presentation. I've looked at this Powerpoint change sound effect volume in macro but it doesn't seem to satisfy my needs.
I tried this:
Sub fadeVolSlideChange(ByVal ShowPos As SlideShowWindow)
Dim ShowPos As Integer
Dim bkgMusic As Shape
Dim Step As Long
ShowPos = ShowPos.View.CurrentShowPosition
Set bkgMusic = ActiveWindow.Selection.ShapeRange(1)
If ShowPos = 2 Then
Set Step = 0.05
For i = 1 To 0.5
With bkgMusic.MediaFormat
.Volume = i
.Muted = False
End With
i = i - Step
Application.Wait (Now + 0.0000025)
Next i
End If
End Sub
With no luck. Thoughts?
Here's the latest edit (still no luck getting it to work):
Sub OnSlideShowPageChange()
Dim i As Integer
Dim bkgMusic As Shape
Dim bkgVol As Long
Dim inc As Long
i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
Set bkgMusic = ActivePresentation.Slides(1).Shapes("Opening Theme")
If i = 1 Then
'Do nothing
ElseIf i <> 1 Then
inc = 0.05
For bkgVol = 1 To 0.1
With bkgMusic.MediaFormat
.Volume = bkgVol
.Muted = False
End With
bkgVol = bkgVol - inc
Application.Wait (Now + TimeValue("0:00:01"))
Next bkgVol
End If
End Sub
This almost works, but PPT shoots us down in the end. After it runs, the volume of the sound file has been reduced, but it doesn't change during the slideshow.
Sub OnSlideShowPageChange()
Dim i As Integer
Dim bkgMusic As Shape
' This needs to be single, not Long
Dim bkgVol As Single
Dim inc As Long
Dim lCounter As Long
i = ActivePresentation.SlideShowWindow.View.CurrentShowPosition
Set bkgMusic = ActivePresentation.Slides(1).Shapes("Opening Theme")
If i = 2 Then
inc = 0.05
' Changing the value by fractions so must be a single, not a long, and
' decreasing the value requires Step and a negative number:
For bkgVol = 1 To 0.1 Step -0.1
With bkgMusic.MediaFormat
.Volume = bkgVol
.Muted = False
End With
'bkgVol = bkgVol - inc
' Application.Wait is not supported in PPT
'Application.Wait (Now + TimeValue("0:00:01"))
WaitForIt
SlideShowWindows(1).View.GotoSlide (2)
Next bkgVol
End If
End Sub
Sub WaitForIt()
Dim x As Long
For x = 1 To 1000000
DoEvents
Next
'MsgBox "Done waiting"
End Sub
Sub macro1()
rep_count = 0
Do
DoEvents
rep_count = rep_count + 1
Sheet1.Shapes("rectangle").Left = rep_count
Sheet1.Shapes("rectangle").Top = rep_count
Sheet1.Shapes("rectangle").Height = rep_count
Sheet1.Shapes("rectangle").Width = rep_count
timeout (0.01)
Loop Until rep_count = 300
End Sub
Sub timeout()
start_time = Timer
Do
DoEvents
Loop Until (Timer - start_time) >= duration_ms
End Sub
the error keep saying "the error
You are passing an argument into the timeout sub procedue that is not in the declaration.
Sub timeout(duration_ms as double) '<~~ pass parameter in here
dim start_time as double
start_time = Timer
Do
DoEvents
Loop Until (Timer - start_time) >= duration_ms
End Sub
Be careful that you do not use this as time crosses midnight. Timer is the number of seconds (and milliseconds) past midnight and resets to zero at midnight.
You can retrieve the shape's name by selecting it and passing this request to the VBE's Immediate window. ?Selection.ShapeRange.name
Use ActiveSheet or Worksheets("sheet1") to reference the shape by name, not the worksheet's codename.
Sub macro1()
Dim rep_Count As Long
rep_Count = 0
Do
DoEvents
rep_Count = rep_Count + 1
'With ActiveSheet.Shapes("Rectangle 1")
With Worksheets("sheet1").Shapes("Rectangle 1")
.Left = rep_Count
.Top = rep_Count
.Height = rep_Count
.Width = rep_Count
End With
timeout (0.01)
Loop Until rep_Count = 300
End Sub
I have a VBA stopwatch in my Excel spreadsheet, code:
Public StopIt As Boolean
Public ResetIt As Boolean
Public LastTime
Private Sub CommandButton1_Click()
Dim StartTime, FinishTime, TotalTime, PauseTime
StopIt = False
ResetIt = False
If Range("C2") = 0 Then
StartTime = Timer
PauseTime = 0
LastTime = 0
Else
StartTime = 0
PauseTime = Timer
End If
StartIt:
DoEvents
If StopIt = True Then
LastTime = TotalTime
Exit Sub
Else
FinishTime = Timer
TotalTime = FinishTime - StartTime + LastTime - PauseTime
TTime = TotalTime * 100
HM = TTime Mod 100
TTime = TTime \ 100
hh = TTime \ 3600
TTime = TTime Mod 3600
MM = TTime \ 60
SS = TTime Mod 60
Range("C2").Value = Format(hh, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00") & "." & Format(HM, "00")
If ResetIt = True Then
Range("C2") = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
PauseTime = 0
End
End If
GoTo StartIt
End If
End Sub
Private Sub CommandButton2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
StopIt = True
End Sub
Private Sub CommandButton3_Click()
Range("C2").Value = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
ResetIt = True
End Sub
This stopwatch works correctly. My problem is that when I change a cell in my spreadsheet or make any changes it resets the stopwatch to '0'.
I want it to run throughout my session as I have other cells which refer to this counter.
Any help would be greatly appreciated. I could not find any similar problems while searching for a solution to this.
Thanks
Not sure if you have found a solution yet, but I did some research and think I know why your code doesn't work, and possibly have another solution... if acceptable...
When I test your code by starting the timer then changing any cell, it doesn't reset to zero but it does stop the timer. Looking at the code you have (which maybe came from https://www.extendoffice.com/documents/excel/3684-excel-create-stopwatch.html), the code is only good for using a simple timer ... nothing else. And since it is never relinquishes control until you stop it, it uses a tremendous amount of your processor (take a look at Task Manager!)
I did find code here on Stack VBA Macro On Timer style to run code every set number of seconds, i.e. 120 seconds and used the second answer (simply too lazy to use first answer at startup).
You can now change cells and the code continues to run (except it 'pauses' while a change is being made to a cell). You may not like the fact that it increments by seconds, but maybe someone else knows a solution to that.
The code does NOT go in a sheet module.
Option Explicit
Dim TimerActive As Boolean
Sub StartTimer()
Start_Timer
End Sub
Private Sub Start_Timer()
TimerActive = True
Application.OnTime Now() + TimeValue("00:00:01"), "Timer"
End Sub
Private Sub Stop_Timer()
TimerActive = False
End Sub
Private Sub Timer()
If TimerActive Then
Activesheet.Cells(2, 3).value = Time
Application.OnTime Now() + TimeValue("00:00:01"), "Timer"
End If
End Sub
my problem today is a part of a subroutine that inexplicably breaks its execution when a Workbook is closed.
I have written the following code:
Public Const Pi As Double = 3.14159265358979
Public Const Rad As Double = Pi / 180
Public CalcBook As Workbook
Public FilePath As String, Files() As String
Public FreqArray() As Integer
Sub Main()
Dim ChooseFolder As Object, FilePath As String, StrFile As String
Dim i As Integer, j As Integer, k As Integer, x As Integer
Dim DirNum As Integer, HNum As Integer, VNum As Integer
Dim DirColShift As Integer, HColShift As Integer, VColShift As Integer
Dim TheStart As Date, TheEnd As Date, TotalTime As Date
Set ChooseFolder = Application.FileDialog(msoFileDialogFolderPicker)
With ChooseFolder
.AllowMultiSelect = False
.Title = "Please choose a folder containing .txt files"
If .Show = -1 Then
FilePath = .SelectedItems(1) & "\"
Else
Set ChooseFolder = Nothing
Exit Sub
End If
End With
Set ChooseFolder = Nothing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
' Stores only files containing an AntennaName + "_T" + any number of characters + "_?_?45.xls" string
' (where "?" is a single character and "*" is any number). Checks if the number of files is correct too.
StrFile = Dir(FilePath & "*_T*_?_?45.txt")
Do While Len(StrFile) > 0
ReDim Preserve Files(i)
Files(i) = FilePath & StrFile
i = i + 1
StrFile = Dir
Loop
If Not (UBound(Files) + 1) / 6 = Int((UBound(Files) + 1) / 6) Then GoTo FileError
For i = 0 To UBound(Files)
Select Case Right(Files(i), 9)
Case "D_+45.txt", "D_-45.txt"
DirNum = DirNum + 1
Case "H_+45.txt", "H_-45.txt"
HNum = HNum + 1
Case "V_+45.txt", "V_-45.txt"
VNum = VNum + 1
End Select
Next
If Not (DirNum / 2 = Int(DirNum / 2) And HNum / 2 = Int(HNum / 2) And VNum / 2 = Int(VNum / 2) And DirNum = HNum And HNum = VNum) Then
FileError:
MsgBox "Failed to properly load files. Looks like a wrong number of them is at dispose", vbCritical, "Check the import-files"
Exit Sub
End If
' Imports files in Excel for better data access
Set CalcBook = Application.Workbooks.Add
' FROM HERE ON THE DATA IS PROCESSED IN ORDER TO OBTAIN AN EXCEL WORKBOOK WITH 3 SHEETS CALLED "Directivity", "Horizontal" and "Vertical".
Application.ScreenUpdating = True
Options.Show
TheStart = Now
Application.ScreenUpdating = False
If Options.OnlyEval = False Then PolarCharts
If Options.OnlyCharts = False Then Auswertung
Application.DisplayAlerts = False
CalcBook.Close savechanges:=False
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Set CalcBook = Nothing
TheEnd = Now
TotalTime = TheEnd - TheStart
MsgBox Format(TotalTime, "HH:MM:SS"), vbInformation, "Computing Time"
Unload Options
End Sub
Options is a form which I need in order to access data for the PolarCharts and Auswertung. These Subs are correctly executed (I know that because the data they save is correct too).
I tried deleting the .ScreenUpdating and .DisplayAlerts commands, as well as the Unload thinking that they could bugging something, but the result hasn't changed.
Know also that the Workbook I'm closing contains NO CODE at all (and nothing else addresses a ".Close" so it's impossible that something is executed on the .Close event).
Below my "Options" code:
Private Sub Cancel_Click()
End
End Sub
Private Sub UserForm_Terminate()
End
End Sub
Private Sub Ok_Click()
If Me.OnlyCharts = False Then
ReDim SubFreq(4)
If Not (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex = -1) Then SubFreq(0) = Me.Start1.List(Me.Start1.ListIndex) & "-" & Me.Stop1.List(Me.Stop1.ListIndex)
If Not (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex = -1) Then SubFreq(1) = Me.Start2.List(Me.Start2.ListIndex) & "-" & Me.Stop2.List(Me.Stop2.ListIndex)
If Not (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex = -1) Then SubFreq(2) = Me.Start3.List(Me.Start3.ListIndex) & "-" & Me.Stop3.List(Me.Stop3.ListIndex)
If Not (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex = -1) Then SubFreq(3) = Me.Start4.List(Me.Start4.ListIndex) & "-" & Me.Stop4.List(Me.Stop4.ListIndex)
If Not (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex = -1) Then SubFreq(4) = Me.Start5.List(Me.Start5.ListIndex) & "-" & Me.Stop5.List(Me.Stop5.ListIndex)
If (Me.Start1 = "" And Me.Start2 = "" And Me.Start3 = "" And Me.Start4 = "" And Me.Start5 = "" And Me.Stop1 = "" And Me.Stop2 = "" And Me.Stop3 = "" And Me.Stop4 = "" And Me.Stop5 = "") _
Or Me.Start1.Value > Me.Stop1.Value Or Me.Start2.Value > Me.Stop2.Value Or Me.Start3.Value > Me.Stop3.Value Or Me.Start4.Value > Me.Stop4.Value Or Me.Start5.Value > Me.Stop5.Value _
Or (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex >= 0) Or (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex >= 0) Or (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex >= 0) Or (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex >= 0) Or (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex >= 0) _
Or (Me.Start1.ListIndex >= 0 And Me.Stop1.ListIndex = -1) Or (Me.Start2.ListIndex >= 0 And Me.Stop2.ListIndex = -1) Or (Me.Start3.ListIndex >= 0 And Me.Stop3.ListIndex = -1) Or (Me.Start4.ListIndex >= 0 And Me.Stop4.ListIndex = -1) Or (Me.Start5.ListIndex >= 0 And Me.Stop5.ListIndex = -1) Then
MsgBox("Please select correctly the frequency ranges - Maybe Start > Stop, one of those was not properly inserted, or the fields are blank", vbExclamation, "Frequency choice error")
GoTo hell
End If
For i = 0 To 4
If Not SubFreq(i) = "" Then j = j + 1
Next i
j = j - 1
ReDim Preserve SubFreq(j)
End If
Me.Hide
hell:
End Sub
Private Sub UserForm_Initialize()
Dim i As Byte
Me.StartMeas = Date
Me.StopMeas = Date
Me.Worker.AddItem "lol"
Me.Worker.AddItem "rofl"
Me.Worker.ListIndex = 0
For i = LBound(FreqArray) To UBound(FreqArray)
Me.Start1.AddItem FreqArray(i)
Me.Start2.AddItem FreqArray(i)
Me.Start3.AddItem FreqArray(i)
Me.Start4.AddItem FreqArray(i)
Me.Start5.AddItem FreqArray(i)
Me.Stop1.AddItem FreqArray(i)
Me.Stop2.AddItem FreqArray(i)
Me.Stop3.AddItem FreqArray(i)
Me.Stop4.AddItem FreqArray(i)
Me.Stop5.AddItem FreqArray(i)
Next i
Me.Start1.ListIndex = 0
Me.Stop1.ListIndex = Me.Stop1.ListCount - 1
End Sub
Apparently when I Close CalcBook, it triggers the UserForm_Terminate event from Options which Ends all the code! How do I avoid this?
Just remove the statement End bacause End causes the abrupt end of code execution.
I see End in the Cancel and Terminate event handlers. If you have it on other places, remove it es well.
If you need exit from a method then use Exit Sub.
Why: because End work that way. Read e.g. this post: http://www.vbforums.com/showthread.php?511766-Classic-VB-Why-is-using-the-End-statement-(or-VB-s-quot-stop-quot-button)-a-bad-idea.
If you need stop code from execution use If-condition or even Exit Sub but avoid using End for it.
Try
Workbooks("CalcBook").Close savechanges:=False
I suspect that both error alerts and indications of an error on the screen are being suppressed