I'm trying to create a stopwatch in Excel in cell K1 with Start and Stop buttons that continues to run even if other cells are updated on the sheet.
I'm trying this code below in the sheet's VBA window, but I keep getting an error message saying "Cannot run the Macro 'UpdateTime'. The macro may not be available in this workbook or all macros may be disabled." I'm positive that macros are enabled and the file is saved as a .xlsm. How should I update the code to make it work?
Sub UpdateTime()
Range("K1").Value = Now - gdtStart
DoEvents
If Not gbStop Then
Application.OnTime Now + TimeSerial(0, 0, 1), "UpdateTime"
End If
End Sub
Private Sub CommandButton1_Click()
Range("K1") = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0,
"00")
gbStop = False
gdtStart = Now
Application.OnTime Now + TimeSerial(0, 0, 1), "UpdateTime"
End Sub
Private Sub CommandButton2_Click()
gbStop = True
End Sub
screenshot of the modules/sheets available
Related
I need help with inserting a sizeable code into "ThisWorkbook" module in Excel using VBA.
Using the code below I'm able to insert the code into "ThisWorkbook" module, but this method (as I've learned recently) has limitations of 24 lines due to line beak (& _).
Sub AddCode()
Dim VBP As Object
Dim newmod As Object
Set VBP = ActiveWorkbook.VBProject
Set newmod = VBP.VBComponents.Add(1)
Dim StartLine As Long
Dim cLines As Long
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
cLines = .CountOfLines + 1
.InsertLines cLines, _
"Private Sub Workbook_Open()" & Chr(13) & _
" Application.Calculation = xlManual" & Chr(13) & _
" Application.CalculateBeforeSave = False" & Chr(13) & _
" Application.DisplayFormulaBar = False" & Chr(13) & _
"Call Module1.ProtectAll" & Chr(13) & _
"End Sub"
End With
End Sub
The code I want to inject in addition to the code above is below (code found on another site). This allows me to track changes on the workbook that I share with others. I do not want to use Excel's built-in "Track Changes" feature.
Dim vOldVal
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim bBold As Boolean
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
bBold = Target.HasFormula
With Sheet1
.Unprotect Password:="Passcode"
If .Range("A1") = vbNullString Then
.Range("A1:E1") = Array("CELL CHANGED", "OLD VALUE", _
"NEW VALUE", "TIME OF CHANGE", "DATE OF CHANGE")
End If
With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
.Value = Target.Address
.Offset(0, 1) = vOldVal
With .Offset(0, 2)
If bBold = True Then
.ClearComments
.AddComment.Text Text:= _
"Note:" & Chr(10) & "" & Chr(10) & _
"Bold values are the results of formulas"
End If
.Value = Target
.Font.Bold = bBold
End With
.Offset(0, 3) = Time
.Offset(0, 4) = Date
End With
.Cells.Columns.AutoFit
.Protect Password:="Passcode"
End With
vOldVal = vbNullString
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
vOldVal = Target
End Sub
How can I achieve this? What is the best and the most efficient way to do this?
I've tried splitting the code in chunks of 20 lines and create 3 "AddCode" sub-routines, but I get an error at "bBold = Target.HasFormula". I have searched the web for alternatives, but nothing seems to be working.
Thanks in advance.
This is an abbreviated version of what I'm doing to create on load code. I create the onload event, then add a new module.
Sub AddOnload()
''Create on load sub
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
.InsertLines 1, "Private Sub Workbook_Open()"
.InsertLines 2, " call CallMe"
.InsertLines 3, "End Sub"
End With
Call CreateCode
End Sub
''Add new module with code
Sub CreateCode()
Dim vbp As VBProject
Dim vbc As VBComponent
Dim strCode
Set vbp = Application.VBE.ActiveVBProject
Set vbc = vbp.VBComponents.Add(vbext_ct_StdModule)
vbc.Name = "tracker"
strCode = "Sub CallMe()" & vbCrLf & "End Sub"
vbc.CodeModule.AddFromString strCode
End Sub
I am using the following vba code in a workbook open event:
Private Sub Workbook_Open()
On Error GoTo Message
Application.AskToUpdateLinks = False
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
ActiveSheet.DisplayPageBreaks = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim currentTime As Date
currentTime = DateAdd("s", 10, Now)
Call CurUserNames
Application.OnTime currentTime, "SaveFile"
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
I also have this code in a module:
Public Sub SaveFile()
On Error GoTo Message
ThisWorkbook.Save
Dim currentTime As Date
currentTime = DateAdd("s", 10, Now)
Application.OnTime currentTime, "SaveFile"
Exit Sub
Message:
Application.DisplayAlerts = False
Exit Sub
End Sub
What I am trying to do is automatically save my workbook every 10 seconds.
This works.
However, something quite annoying I've noticed happens. If a user has this workbook open in the background and is working on another excel workbook then this workbook will activate and display on top of the other workbook when saving.
This can be quite annoying for the user.
Is there a way I can get my workbook to save without activating the workbook?
P.S:
For some unknown reason, this also causes the workbook to reopen when its been closed.
EDIT:
List active users in workbook code:
Sub CurUserNames()
Dim str As String
Dim Val1 As String
str = "Users currently online:" & Chr(10)
For i = 1 To UBound(ThisWorkbook.UserStatus)
str = str & ThisWorkbook.UserStatus(i, 1) & ", "
Next
Val1 = DeDupeString(Mid(str, 1, Len(str) - 2))
Worksheets("Delivery Tracking").Range("F4").Value = Val1
End Sub
Function DeDupeString(ByVal sInput As String, Optional ByVal sDelimiter As String = ",") As String
Dim varSection As Variant
Dim sTemp As String
For Each varSection In Split(sInput, sDelimiter)
If InStr(1, sDelimiter & sTemp & sDelimiter, sDelimiter & varSection & sDelimiter, vbTextCompare) = 0 Then
sTemp = sTemp & sDelimiter & varSection
End If
Next varSection
DeDupeString = Mid(sTemp, Len(sDelimiter) + 1)
End Function
Users of a shared workbook can see Who has this workbook open now: just by going to the Review tab in the Ribbon and click the Shared Workbook icon in the Changes group. This will open the Shared Workbook dialog box, in it the tab Editing' shows *Who has this workbook open now:`*. Additionally the tab 'Advance' can be used to update the settings dealing with:
Track changes
Update changes
Conflicting changes between users
Include in personal view
Th9is example comes from How can I get list of users using specific shared workbook?
It is a little overkill. It creates a new workbook to put the users name in. But you can modify it to put the names in whatever sheet and whatever cells you want.
Put it in the sheet module under the selection change module. Then it will update every time the user moves to a different cell. If it is open and he's not at his desk - it doesn't do anything.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
At the bottom is the code from the above link that you can modify to suit your own needs. It will be 1000 times better than saving a workbook every ten seconds. Which can actually take 3 or 4 seconds itself.
If you don't want to use selection change in the worksheet module then you could put your code into the workbook module Private Sub Workbook_Open()
and put it on a timer to run every 10 seconds. It will only take a fraction of a second instead of several seconds.
users = ActiveWorkbook.UserStatus
With Workbooks.Add.Sheets(1)
For row = 1 To UBound(users, 1)
.Cells(row, 1) = users(row, 1)
.Cells(row, 2) = users(row, 2)
Select Case users(row, 3)
Case 1
.Cells(row, 3).Value = "Exclusive"
Case 2
.Cells(row, 3).Value = "Shared"
End Select
Next
End With
I'm trying to capture a specific drag and drop event in VBA, and would like to disable the popup "There's already data here. Do you want to replace it?" during this event.
I have the basic event of a drag+drop from cell [D1] to cell [E1] captured, but for some reason I'm unable to disable the popup. Does anyone know why?
Thanks so much.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target(1, 1), [D1]) Is Nothing Then
MsgBox "selected " & Target.Address & " - " & Target(1, 1).Value
Application.DisplayAlerts = False
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target(1, 1), [E1]) Is Nothing Then
MsgBox "changed " & Target.Address & " - " & Target(1, 1).Value
End If
End Sub
Try this - it works on my 2013 Excel:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target(1, 1), [E1]) Is Nothing Then
MsgBox "changed " & Target.Address & " - " & Target(1, 1).Value
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target(1, 1), [D1]) Is Nothing Then
MsgBox "selected " & Target.Address & " - " & Target(1, 1).Value
Application.AlertBeforeOverwriting = False
Else
Application.AlertBeforeOverwriting = True
End If
End Sub
This uses the SelectionChange event to catch the user selecting D1 and disables the alert using Application.AlertBeforeOverwriting. Any other selection ensures it's enabled. Dragging the value causes another SelectionChange which now re-enables the alert for any other overwriting.
Also, you ought to use events to trap user clicking in D1 and then changing to another sheet or closing this one as the alerts could remain disabled.
Why did you put
Application.DisplayAlerts = False
after the drag and drop code? Move it before it.
This macro is one that was not written by me, so I'm having trouble understanding the source of the error. I have a macro that's supposed to run on startup to adjust the ribbon to add a button, and another part to remove styles when you select that button. Currently, I get the message: Object variable or With block variable not set. When I select "Debug" it goes to the VBA screen and immediately gives me 3 more error pop-ups that say: Can't execute code in break mode.
The first part of this is the two subs that are to run on startup, which are:
Dim WithEvents app As Application
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
Module1.MyRibbon.Invalidate
End Sub
Private Sub Workbook_Open()
Set app = Application
End Sub
It highlights the Module1.MyRibbon.Invalidateas the problematic bit. Personally I don't see anything wrong with this per se, but perhaps the problem is in the Module 1? That code contains three subs, as follows:
Public MyRibbon As IRibbonUI
'Callback for customUI.onLoad
Sub CallbackOnLoad(Ribbon As IRibbonUI)
Set MyRibbon = Ribbon
End Sub
'Callback for customButton getLabel
Sub GetButtonLabel(control As IRibbonControl, ByRef returnedVal)
If ActiveWorkbook Is Nothing Then
returnedVal = "Remove Styles"
Else
returnedVal = "Remove Styles" & vbCr &
Format(ActiveWorkbook.Styles.Count, "#" & Application.International(xlThousandsSeparator) & "##0")
End If
End Sub
Sub RemoveTheStyles(control As IRibbonControl)
Dim s As Style, i As Long, c As Long
On Error Resume Next
If ActiveWorkbook.MultiUserEditing Then
If MsgBox("You cannot remove Styles in a Shared workbook." & vbCr & vbCr & _
"Do you want to unshare the workbook?", vbYesNo + vbInformation) = vbYes Then
ActiveWorkbook.ExclusiveAccess
If Err.Description = "Application-defined or object-defined error" Then
Exit Sub
End If
Else
Exit Sub
End If
End If
c = ActiveWorkbook.Styles.Count
Application.ScreenUpdating = False
For i = c To 1 Step -1
If i Mod 600 = 0 Then DoEvents
Set s = ActiveWorkbook.Styles(i)
Application.StatusBar = "Deleting " & c - i + 1 & " of " & c & " " & s.Name
If Not s.BuiltIn Then
s.Delete
If Err.Description = "You cannot use this command on a protected sheet. To use this command, you must first unprotect the sheet (Review tab, Changes group, Unprotect Sheet button). You may be prompted for a password." Then
MsgBox Err.Description & vbCr & "You have to unprotect all of the sheets in the workbook to remove styles.", vbExclamation, "Remove Styles AddIn"
Exit For
End If
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
I've never written any Activation or Ribbon-related macro, so I have no idea where the error could be. The addin works just find regardless of this message, as the button gets added and it functions as it should when the file isn't a blank file, but I get the error pop-up and the button doesn't get created right on new, blank files. How could I fix this?
I simply deleted:
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
Module1.MyRibbon.Invalidate
End Sub
No runtime errors on start of excel and no issues when using the script; counts fine and deletes fine. Windows 7, Excel 2010.
I have a spreadsheet with 6 userforms, used on about 30 computers. The VBA code is password protected. Often when we close the sheet, the VBA project password box appears and excel.exe remains in task manager.
I have done a bit of testing and come up with the following:
The problem only occurs when a userform has been opened.
Nothing needs to be done with the userform to cause the popup other than to press Cancel (which calls Unload Me)
The Workbook_BeforeClose event is as follows:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
'Cancel autosave
Sheets("BOH General").Range("A102").Value = 0
AutoSaveTimer
'Application.EnableEvents = False
If Not Sheets("START").Visible = True Then Call CostingMode
Call BackItUp
'Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
And here are some other macros called by Workbook_BeforeClose:
Sub AutoSaveTimer()
If Sheets("BOH General").Range("A102").Value > 0 Then
RunWhen = Now + TimeSerial(0, Sheets("BOH General").Range("A102").Value, 0)
Application.OnTime EarliestTime:=RunWhen, Procedure:="AutoSaveIt", _
Schedule:=True
Else
On Error Resume Next
Application.OnTime EarliestTime:=RunWhen, Procedure:="AutoSaveIt", _
Schedule:=False
On Error GoTo 0
End If
End Sub
Sub AutoSaveIt()
ThisWorkbook.Save
Call AutoSaveTimer
End Sub
Sub BackItUp()
'Dont run if unsaved
If Sheets("BOH General").Range("A111").Value = "" Then Exit Sub
'Prompt
If MsgBox("Do you want to backup this sheet now (recommended if you made any changes)?", vbYesNo) = vbNo Then Exit Sub
'reformat date
Dim DateStamp As String
DateStamp = Format(Now(), "yyyy-mm-dd hh-mm-ss")
On Error Resume Next
MkDir ActiveWorkbook.Path & "\" & "Backup"
On Error GoTo 0
ActiveWorkbook.SaveCopyAs (ActiveWorkbook.Path & "\" & "Backup" & "\" & ActiveWorkbook.Name & " - backup " & DateStamp & ".xlsb")
ActiveWorkbook.Save
End Sub
Is this a userform error, is the userform not closing properly? Or is it something else?
UPDATE: This error only occurs after the user clicks the excel close button (top right) clicking File>Close does not produce the error.
Interesting that I have been experiencing the same instance, it has only cropped up recently as well. Did a version of MOS change this behavior? I have users on Excel 12.0.6611.1000 and 12.0.6712.5000 that do not get this error, on 12.0.6729.5000 it always occurs.
Edit;
I resolved this issue on my end today after discovering that several users had 'Drop Box' installed. Uninstalling or turning off drop box just prior to closing the application resolved the issue.