I have come across a strange glitch in a code that I found online. if I have two different spreadsheets open, one with this code in it and another that may well have no macros at all, and i leave that one alone for the specified time (as is the time I allow for in the macro) then the spreadsheet that has the macro in closes on me and then after the given time, the other spreadsheet closes too. Why does this happen?
Module 1:
Dim DownTime As Date
Sub SetTimer()
DownTime = Now + TimeValue("00:00:20")
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=False
End Sub
Sub ShutDown()
Application.DisplayAlerts = False
Call ExampleToSaveWorkbook
With ThisWorkbook
.Saved = True
.Close
End With
End Sub
Sub ExampleToSaveWorkbook()
'Saving the Workbook
bnam = ActiveWorkbook.Name
filenm = "S:\Economics\GTAA\dailyPM\excelfiles\backups\" & bnam
ActiveWorkbook.SaveAs filenm
End Sub
ThisWorkbook
Private Sub Workbook_Open()
Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
Call StopTimer
Call SetTimer
End Sub
Why is it closing more than the 1 workbook which has the macro?
The Shutdown sub calls ExampleToSaveWorkbook which closes the active workbook.
The remainder of the Shutdown then proceeds to close the ThisWorkBook object.
Related
Does anyone know any VBA code that will close and save an excel file after a delay? I tried some kutools code that was supposed to close only after some idle time but it closes without checking for inactivity.
Paste in Routine Module:
Option Explicit
Const idleTime = 30 'seconds
Dim Start
Sub StartTimer()
Start = Timer
Do While Timer < Start + idleTime
DoEvents
Loop
'///////////////////////////////////////////////////////
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Step 1: Declare your variables
Dim ws As Worksheet
'Step 2: Unhide the Starting Sheet
Sheets("Sheet1").Visible = xlSheetVisible
'Step 3: Start looping through all worksheets
For Each ws In ThisWorkbook.Worksheets
'Step 4: Check each worksheet name
If ws.Name <> "Sheet1" Then
'Step 5: Hide the sheet
ws.Visible = xlVeryHidden
End If
'Step 6: Loop to next worksheet
Next ws
'Application.ScreenUpdating = True
Range("A1").Select
ThisWorkbook.Save
'Application.DisplayAlerts = True
'//////////////////////////////////////////////////////////
'Application.DisplayAlerts = False
Application.Quit
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End Sub
Paste in ThisWorkbook :
Option Explicit
Private Sub Workbook_Open()
StartTimer
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
StartTimer
End Sub
Paste in Routine Module:
Sub Reset()
Static SchedSave
If SchedSave <> 0 Then
Application.OnTime SchedSave, "SaveWork", , False
End If
SchedSave = Now + TimeValue("00:10:00") '<--- Ten minutes
Application.OnTime SchedSave, "SaveWork", , True
End Sub
Sub SaveWork()
MsgBox "Run the close workbook macro here."
'ThisWorkbook.Save
'Application.Quit
'ThisWorkbook.Close
End Sub
Paste in ThisWorkbook:
Private Sub Workbook_Open()
Reset
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Reset
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Reset
End Sub
Timer will start automatically when workbook is opened. Presently set for 10 minutes (can be adjusted). Closing macro code has been disabled and presently replaced with a MsgBox notice.
I have a situation where multiple users will need to access a workbook (want to avoid using the 'Share Workbook' option due to all the problems). I've determined that a possible solution to this is to get the workbook to automatically close after 15 minutes of inactivity.
I would also like a message to pop up after the 15 minutes which alerts the user that unless they click the 'okay' button, the workbook will close. If they click the button, I would like the counter to start over, and ideally if they don't click anything the workbook will automatically closer after a further 1 minute.
I have found some code online which I have used. The workbook successfully closes after a specified time but I can't figure out how to get the message box to pop up. Would appreciate any help, thanks!
Code I used is below:
In module 1:
Dim DownTime As Date
Sub SetTimer()
DownTime = Now + TimeValue("0:15:00")
Application.OnTime EarliestTime:=DownTime, _
Procedure = "ShutDown", Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=False
End Sub
Sub ShutDown()
Application.DisplayAlerts = False
With ThisWorkbook
.Saved = True
.Close
End With
End Sub
And in ThisWorkbook:
Private Sub Workbook_Open()
Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
Call StopTimer
Call SetTimer
End Sub
Try the below ShutDown procedure:
Sub ShutDown()
If CreateObject("WScript.Shell").PopUp("Close Excel?", 60, "Excel", vbOKCancel + vbQuestion + vbSystemModal) = vbCancel Then
StopTimer
SetTimer
Exit Sub
End If
Application.DisplayAlerts = False
With ThisWorkbook
.Saved = True
.Close
End With
End Sub
Never 'share' Excel files on a network drive with coworkers. You will encounter all kinds of problems, including workbook corruption, and other things. Try this script, to auto-close your Excel files after n-minutes of inactivity.
To start, add the following code to a standard macro module. Note that there are three routines to be added:
Dim DownTime As Date
Sub SetTimer()
DownTime = Now + TimeValue("01:00:00")
Application.OnTime EarliestTime:=DownTime, _
Procedure = "ShutDown", Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=DownTime, _
Procedure:="ShutDown", Schedule:=False
End Sub
Sub ShutDown()
Application.DisplayAlerts = False
With ThisWorkbook
.Saved = True
.Close
End With
End Sub
The next routines (there are four of them) need to be added to the ThisWorkbook object. Open the VBA Editor and double-click on the ThisWorkbook object in the Project Explorer. In the code window that Excel opens, place these routines:
Private Sub Workbook_Open()
Call SetTimer
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Call StopTimer
Call SetTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Excel.Range)
Call StopTimer
Call SetTimer
End Sub
See this for all info.
http://excelribbon.tips.net/T008192_Forcing_a_Workbook_to_Close_after_Inactivity.html
In a template's workbook_open event, I have a hotkey ^m registered to launch a UserForm DataValidation:
Private Sub workbook_open()
Application.OnKey "^m", "launchDataValidation"
End Sub
Sub launchDataValidation()
DataValidation.Show
End Sub
It's possible that there will be multiple workbooks open at the same time that are built from this template. I want to make sure that when the user presses the hotkey, the UserForm that is launched is from the active workbook, so that any operations executed by that UserForm will only affect that workbook.
I tried rewriting launchDataValidation as:
Sub launchDataValidation()
On Error GoTo errHandler
ActiveWorkbook.DataValidation.Show
Exit Sub
errHandler:
End Sub
The intent is that the active workbook's DataValidation form opens, and if the active book doesn't have a DataValidation form, nothing happens. But instead, the ActiveWorkbook.DataValidation.Show call goes to the error handler, suggesting that this is not the correct way to open that form in the active workbook.
I also tried:
Sub launchDataValidation()
Dim bkName As String
Dim runString As String
bkName = ActiveWorkbook.Name
runString = "'" & bkName & "'!DataValidation.Show"
On Error GoTo errHandler
Application.Run runString
Exit Sub
errHandler:
End Sub
This also threw an error.
Figured it out:
Private Sub workbook_open()
Application.OnKey "^m", "launchDataValidation_ActiveBook"
End Sub
Sub launchDataValidation()
DataValidation.Show
End Sub
Sub launchDataValidation_ActiveBook()
Dim bkName As String
Dim runString As String
bkName = ActiveWorkbook.Name
runString = "'" & bkName & "'!launchDataValidation"
On Error GoTo errHandler
Application.Run runString
Exit Sub
errHandler:
End Sub
I have a sub that goes through each worksheet and checks for a flag.
If the flag is raised, I want it to run another sub. The flag checking works, but the other sub which is called runs on the main sheet.
Code:
Sub update()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If (ws.Cells(1, 5) = 1) Then
Call update2(ws)
End If
Next
End Sub
Sub update2(ws As Worksheet)
ws.clear <----does not work
End Sub
sub dothis()
cells(1,6) = "hallo"
end sub
how do I get this to work?
You need to either use a public variable (generally not recommended) or send the necessary arguments to the procedure(s) where they are needed.
Sub update2(ws As Worksheet)
Call dothis(ws)
End Sub
sub dothis(ws as Worksheet)
ws.cells(1,6) = "hallo"
end sub
Sub update2(ws As Worksheet)
ws.Cells.Clear
End Sub
How can VBA keep track of which workbooks are open?
I am writing a data mining macro that takes information from a variable number of workbooks. The user may choose what workbooks will be parsed via a userform. However, workbooks can be opened and closed while the userform is running.
So, how can my userform keep track of which workbooks are open, so that it can display them accurately.
Right now, I'm using a recursive function that calls itself with "Application.OnTime". I don't really like this solution for because it involves extra checks to see if the userform is still open, as well as having a delay because of whatever period the function is called at.
Final: Combined solution from answers and comments
userform code, requires a ListBox called WorkbookList, and a Textbox called FileTextBox
Private WithEvents App As Application
Public Sub WorkbookList_UpdateList()
WorkbookList.Clear
For Each Wb In Application.Workbooks
WorkbookList.AddItem Wb.name
Next Wb
End Sub
Private Sub WorkbookList_Change()
If WorkbookList.ListIndex = -1 Then Exit Sub
key = WorkbookList.List(WorkbookList.ListIndex)
For Each Wb In Application.Workbooks
IsWorkBookOpen Wb.path
If Wb.name = key Then FileTextbox.text = Wb.path
Next Wb
End Sub
Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
WorkbookList_UpdateList
End Sub
Private Sub App_NewWorkbook(ByVal Wb As Workbook)
WorkbookList_UpdateList
End Sub
Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Application.OnTime Now + TimeValue("00:00:01"), "WorkbookClosed"
End Sub
Private Sub UserForm_Initialize()
Set App = Application
WorkbookList_UpdateList
UpdatePeriodicly
End Sub
module code (put this in a vba module):
'Code From: http://www.ozgrid.com/forum/showthread.php?t=152892
Function IsUserFormLoaded(ByVal UFName As String) As Boolean
Dim UForm As Object
IsUserFormLoaded = False
For Each UForm In VBA.UserForms
If UForm.name = UFName Then
IsUserFormLoaded = True
Exit For
End If
Next
End Function
Public Sub WorkbookClosed()
If IsUserFormLoaded("InputForm") = False Then Exit Sub
InputForm.WorkbookList_UpdateList
End Sub
You can use Application Events fgor this.
E.g. see cpearson.com/excel/appevent.aspx
Private WithEvents app As Excel.Application
Sub Init()
Set app = Application 'start capturing events
End Sub
Private Sub app_NewWorkbook(ByVal Wb As Workbook)
Debug.Print "New"
End Sub
Private Sub app_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
Debug.Print "Before close: " & Wb.Name
End Sub
Private Sub app_WorkbookOpen(ByVal Wb As Workbook)
Debug.Print "Open: " & Wb.Name
End Sub
So I think that this is an interesting script and something that might be useful for the problem your trying to solve.
Public Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False 'Workbook IS NOT
Case 70: IsWorkBookOpen = True 'Workbook IS open
Case Else: Error ErrNo
End Select
End Function
You can call this by doing something like this
Ret = IsWorkBookOpen("C:\test.xlsm")
If Ret = True Then 'YOUR CODE HERE