Module1:
Sub TimeCheck()
Dim ValueTime As Date
Dim SysTime As Date
ValueTime = Sheets("mylinks").Range("A22").Value
SysTime = Now()
If TimeValue(ValueTime) >= TimeValue(SysTime) Then
MsgBox ("Check the Aplication")
End If
End Sub
Private Sub Workbook_open()
alertTime = Now + TimeValue("00:00:05")
Application.OnTime alertTime, "Timecheck"
End Sub
The above code is not working. Can someone help me with this?
Related
I made a workbook that has a userform thar is used to fill information in a new row, the information in the textboxes should be prefilled by using the information on the row below. This has to be repeated as many times as an input box value.
So far so good, but now I also need the users to be able to view other sheets in the same workbook where the required information is stored while the userform is open.
if I show the userform modeless I can view other sheets but then the code just keeps going and the second time the userform should pop up it doesn't.
I found a solution to that: using DoEvent.
but now the information is not (pre)filled correctly
Private Sub CommandButton2_Click()
Dim myValue As String
myValue = InputBox("How many do you have?")
If StrPtr(myValue) = 0 Then Exit Sub
For i = 1 To myValue
Range("A4").EntireRow.Insert
UserForm1.Show vbModeless
Do While UserForm1.Visible
DoEvents
Loop
Next
End Sub
What happens now is that the information from a row below is used regardless of any changes made by the user.
Does anyone have a solution?
Edit:
I don't think it is immediately required to understand my question but it might help a bit..
The rest of the code from the userform is as follows
Private Sub CommandButton1_Click()
Unload UserForm1
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Range("A4").EntireRow.delete
End
End If
End Sub
Private Sub TextBox1_Change()
Dim myValue As Variant
myValue = TextBox1
Range("A4").Value = myValue
End Sub
Private Sub UserForm_Initialize()
Me.TextBox1.Value = Format(Range("A2"), "dd/mm/yyyy")
Me.TextBox2.Value = Range("B5").Value
Me.TextBox3.Value = Range("C5").Value
Me.TextBox4.Value = Range("D5").Value
Me.TextBox5.Value = Range("E5").Value
Me.TextBox6.Value = Range("F5").Value
Me.TextBox7.Value = Range("G5").Value
Me.TextBox8.Value = Range("H5").Value
Me.TextBox9.Value = Range("J5").Value
Me.TextBox10.Value = Range("K5").Value
End Sub
Private Sub TextBox10_Change()
Dim myValue As Variant
myValue = TextBox10
Range("K4").Value = myValue
End Sub
Private Sub TextBox11_Change()
End Sub
Private Sub TextBox2_Change()
Dim myValue As Variant
myValue = TextBox2
Range("B4").Value = myValue
End Sub
Private Sub TextBox3_Change()
Dim myValue As Variant
myValue = TextBox3
Range("C4").Value = myValue
End Sub
Private Sub TextBox4_Change()
Dim myValue As Variant
myValue = TextBox4
Range("D4").Value = myValue
End Sub
Private Sub TextBox5_Change()
Dim myValue As Variant
myValue = TextBox5
Range("E4").Value = myValue
End Sub
Private Sub TextBox6_Change()
Dim myValue As Variant
myValue = TextBox6
Range("F4").Value = myValue
End Sub
Private Sub TextBox7_Change()
Dim myValue As Variant
myValue = TextBox7
Range("G4").Value = myValue
End Sub
Private Sub TextBox8_Change()
Dim myValue As Variant
myValue = TextBox8
Range("H4").Value = myValue
End Sub
Private Sub TextBox9_Change()
Dim myValue As Variant
myValue = TextBox9
Range("J4").Value = myValue
End Sub
~~
I figured that it indeed had to do with the fact that your initial code did not retrigger the TextBox#_Change subs as intended. I did it a little differently, and triggered them in CommandButton2_Click. This way, you don't need to reload really. But whatever works; just sharing for comparison. So, I am assuming a UserForm like this:
We will move row 4 down on Confirm Input. On Cancel, we'll clear it and exit. And on Confirm Input, the user will (continuously) be asked whether he wants to submit another entry. If not, we'll clear row 4 and exit as well.
So, I've rewritten these parts:
Private Sub CommandButton1_Click()
Range("A4").EntireRow.ClearContents
Unload UserForm1
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Range("A4").EntireRow.ClearContents
Range("A4").Resize(1, 11).Interior.Color = vbYellow
End
End If
End Sub
Private Sub CommandButton2_Click()
Range("A4").Resize(1, 11).Interior.Color = vbWhite
Range("A4").Resize(1, 11).Insert
Range("A4").Resize(1, 11).Interior.Color = vbYellow
For i = 1 To 10
myValue = Me.Controls("TextBox" & i).Value
Me.Controls("TextBox" & i).Value = ""
Me.Controls("TextBox" & i).Value = myValue
Next i
answer = MsgBox("Do you wish to add another row?", vbYesNo)
If answer = vbYes Then
Else
Range("A4").EntireRow.ClearContents
Unload UserForm1
End If
End Sub
Private Sub TextBox1_Change()
Dim myValue As Variant
myValue = TextBox1
If myValue = "" Then
Range("A4").Value = myValue
Else
Range("A4").Value = CDate(myValue)
End If
End Sub
You might want to get rid of the color (re)setting bits. But it may be good to realize that the practice of inserting rows all the time may have unintended effects for formatting. Suppose, for whatever reason, you want row 6 to have a red background. As is, the code will keep pushing this formatting one row down each time. This may be what you want, of course... Other than that, the "update" for TextBox1_Change makes sure you export an actual Excel Date, not a string.
Final warning (since we're using vbModeless): be aware that (both in your code and mine) there is no reference to the worksheet. Suppose your user goes into another sheet and clicks Confirm Input there, this will trigger Range("A4").Resize(1, 11).Insert inside the wrong sheet! Seems highly advisable to fix this.
I found a way..
I now changed the sub names of the textbox#_change subs and call them all on "userform unload".
Private Sub CommandButton1_Click() ' this is the command button on the userform
Call TX1
Unload UserForm1
End Sub
I need to write a code in VBA and use a userform to show multiple images of the same item and rank them which one would be the best. I need the number, 1 being the best one to 3 being the last pick to be stored in a cell next to the image. I will put screenshots of my data as well as the userform I made. Below is the code I wrote but somehow not showing any images at all.
Thank you.
Dim ImageName As String
Dim CopyImage As String
Private Sub CheckBox1_Click()
End Sub
Private Sub CheckBox2_Click()
End Sub
Private Sub CheckBox3_Click()
End Sub
Private Sub CheckBox4_Click()
End Sub
Private Sub CheckBox5_Click()
End Sub
Private Sub CheckBox6_Click()
End Sub
Private Sub CheckBox7_Click()
End Sub
Private Sub CheckBox8_Click()
End Sub
Private Sub cmdNext_Click()
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
MsgBox "Last Row"
ActiveCell.Offset(-1, 0).Select
Exit Sub
Else
Call GetImage
End If
End Sub
Private Sub cmdSave_Click()
ActiveCell.Offset(6349, 11).Select
If ActiveCell.Value = "" Then
MsgBox "Saved"
ActiveCell.Offset(6349, 11).Select
Exit Sub
Else
Call GetImage
End If
End Sub
Private Sub cmdLoad_Click()
If ActiveCell.Column <> 1 Or ActiveCell.Row = 1 Or ActiveCell.Value = "" Then
Cells(6349, 10).Select
End If
Call GetImage
cmdBack.Enabled = True
cmdNext.Enabled = True
End Sub
Private Sub cmdBack_Click()
ActiveCell.Offset(-1, 0).Select
If ActiveCell.Value = "" Then
MsgBox "Last Row"
ActiveCell.Offset(1, 0).Select
Exit Sub
Else
Call GetImage
End If
End Sub
Private Sub RankButton_Click()
End Sub
Private Sub DeleteButton_Click()
End Sub
Private Sub ClearButton_Click()
End Sub
Private Sub Image1_Click()
End Sub
Private Sub Image2_Click()
End Sub
Private Sub Image3_Click()
End Sub
Private Sub Image4_Click()
End Sub
Private Sub Image5_Click()
End Sub
Private Sub Image6_Click()
End Sub
Private Sub Image7_Click()
End Sub
Private Sub Image8_Click()
End Sub
Private Sub UserForm_Initialize()
cmdBack.Enabled = False
cmdNext.Enabled = False
'cmdSave.Enabled = False
End Sub
Private Sub GetImage()
Dim PhotoNames As String, fPath As String, iFile As String
Dim i As Integer
fPath = "D:\transfer\2021-12-13_image_ranking\dayco\2021-11-15_merged_dayco\"
Dim CurrentPartNumber As String
Dim CurrentImageIndex As Integer
CurrentImageIndex = 1
CurrentPartNumber = ActiveCell.Value
Sheets("IMAGE").Select
Dim CurrentCellValue As String
Dim CurrentRow As Long
CurrentRow = 6349
CurrentCellValue = Cells(CurrentRow, 10)
While Not (CurrentCellValue = "")
If CurrentCellValue = CurrentPartNumber Then
If Not Dir(fPath & Cells(CurrentRow, 10).Value) = "" Then
Me.Controls("Image" & CurrentImageIndex).Picture = LoadPicture(fPath & Cells(CurrentRow, 10).Value)
CurrentImageIndex = CurrentImageIndex + 1
End If
End If
CurrentRow = CurrentRow + 1
CurrentCellValue = Cells(CurrentRow, 1)
Wend
End Sub
I have a code that works fine until I added a MsgBox confirmation if the user wants to end the timer. The userform just shows a timer starting zero everytime a user starts a task.
I tried replacing "myTimer", , False -> "myTimer", , True but the timer just continues to increment in the background.
-----Userform-----
Private Sub UserForm_Initialize()
Call myTimer
StartTime = Timer
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _CloseMode As Integer)
If MsgBox("Are you sure to End Time?", vbYesNo) = vbYes Then
myTimer_Cancel
Else
Cancel = True
End If
End Sub
-----Module-----
Option Explicit
Public StartTime As Single
Public Sub myTimer()
Dim elapsedtime As Single
elapsedtime = Timer - StartTime
UserForm2.Label2.caption = Format(CDate(elapsedtime / 86400), "hh:nn:ss")
Application.OnTime Now + timeValue("00:00:01"), "myTimer"
End Sub
Public Sub myTimer_Cancel()
Application.OnTime Now + timeValue("00:00:01"), "myTimer", , False
End Sub
When you cancel a timer you must use the same exact time you used when you set it, so:
-----Userform-----
Private Sub UserForm_Initialize()
Call myTimer
StartTime = Timer
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _CloseMode As Integer)
If MsgBox("Are you sure to End Time?", vbYesNo) = vbYes Then
myTimer_Cancel
Else
Cancel = True
End If
End Sub
-----Module-----
Option Explicit
Public StartTime As Single
Public NextRun ' << store next run time
Public Sub myTimer()
Dim elapsedtime As Single
elapsedtime = Timer - StartTime
UserForm2.Label2.caption = Format(CDate(elapsedtime / 86400), "hh:nn:ss")
NextRun = Now + timeValue("00:00:01")
Application.OnTime NextRun, "myTimer"
End Sub
Public Sub myTimer_Cancel()
Application.OnTime NextRun, "myTimer", , False
End Sub
VBA code for autosaving and for closing the workbook if idle is working. The problem is, Excel continues to run the code if another instance of the program was open when the code closed the workbook. I think what I need to do is to unload the workbook, but I can't figure out how. I've tried "Unload Workbook," "Unload ThisWorkbook," and "Unload ResetTimer" [the module which detects activity and starts the 35 minute timer over]. I'm getting an error that Workbook/ThisWorkbook/ResetTimer are not object that can be unloaded. I can't find a list of what objects can be unloaded.
Here is the code under ThisWorkbook
Option Explicit
Private Sub ThisWorkbook_Open()
If ThisWorkbook.ReadOnly = False Then
Application.OnTime Now + TimeValue("00:30:00"), "SaveThis"
End If
If ThisWorkbook.ReadOnly = False Then
Application.OnTime Now + TimeValue("00:35:00"), "CloseDownFile"
End If
End Sub
Private Sub ThisWorkbook_Close()
Unload ThisWorkbook
' Unload ResetTimer
End Sub
Private Sub ThisWorkbook_SheetCalculate(ByVal Sh As Object)
ResetTimer
End Sub
Private Sub ThisWorkbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub
Private Sub ThisWorkbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ResetTimer
End Sub
Here is the Module:
Public CloseDownTime As Variant
Public Sub ResetTimer()
On Error Resume Next
If Not IsEmpty(CloseDownTime) Then Application.OnTime EarliestTime:=CloseDownTime, Procedure:="CloseDownFile", Schedule:=False
CloseDownTime = Now + TimeValue("00:35:00") ' change as needed
Application.OnTime CloseDownTime, "CloseDownFile"
End Sub
Public Sub CloseDownFile()
On Error Resume Next
ThisWorkbook.Close SaveChanges:=True
Unload ThisWorkbook
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.OnTime Now + TimeValue("00:30:00"), "SaveThis"
End Sub
Your regular module should look more like this (see below). This removes the logic from your ThisWorkbook module.
Option Explicit
Public CloseTime As Variant
Public SaveTime As Variant
Public Sub StartTimers()
StartSaveTimer
StartCloseTimer
End Sub
Public Sub CancelTimers()
CancelSaveTimer
CancelCloseTimer
End Sub
Sub StartSaveTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelSaveTimer 'remove any existing timer
SaveTime = Now + TimeValue("00:30:00")
Application.OnTime SaveTime, "SaveThis"
End Sub
Sub CancelSaveTimer()
On Error Resume Next
Application.OnTime EarliestTime:=SaveTime, Procedure:="SaveThis", Schedule:=False
On Error GoTo 0
End Sub
Sub StartCloseTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelCloseTimer 'remove any existing timer
CloseTime = Now + TimeValue("00:35:00")
Application.OnTime CloseTime, "CloseThis"
End Sub
Sub CancelCloseTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseThis", Schedule:=False
On Error GoTo 0
End Sub
Public Sub CloseThis()
On Error Resume Next
CancelTimers
ThisWorkbook.Close SaveChanges:=True
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
StartSaveTimer
End Sub
Here is the corrected code to save every 30 minutes and to close after 35 minutes of no use. Thank you to #TimWilliams for all of the help!
Code under ThisWorkbook:
Option Explicit
Private Sub Workbook_Open()
Call StartTimers
End Sub
Private Sub Workbook_Close()
CancelTimers
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
CancelCloseTimer
StartCloseTimer
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
CancelCloseTimer
StartCloseTimer
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
CancelCloseTimer
StartCloseTimer
End Sub
Code for Module:
Option Explicit
Public CloseTime As Variant
Public SaveTime As Variant
Public Sub StartTimers()
StartSaveTimer
StartCloseTimer
End Sub
Public Sub CancelTimers()
CancelSaveTimer
CancelCloseTimer
End Sub
Sub StartSaveTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelSaveTimer 'remove any existing timer
SaveTime = Now + TimeValue("00:30:00") 'save frequency, change as needed
Application.OnTime SaveTime, "SaveThis"
End Sub
Sub CancelSaveTimer()
On Error Resume Next
Application.OnTime EarliestTime:=SaveTime, Procedure:="SaveThis", Schedule:=False
On Error GoTo 0
End Sub
Sub StartCloseTimer()
If ThisWorkbook.ReadOnly Then Exit Sub
CancelCloseTimer 'remove any existing timer
CloseTime = Now + TimeValue("00:35:00") 'idle time before closing, change as needed
Application.OnTime CloseTime, "CloseThis"
End Sub
Sub CancelCloseTimer()
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseThis", Schedule:=False
On Error GoTo 0
End Sub
Public Sub CloseThis()
On Error Resume Next
CancelTimers
ThisWorkbook.Close SaveChanges:=True
End Sub
Sub SaveThis()
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
StartSaveTimer
End Sub
Couple of macros are used. In then "ThisWorkbook" module, paste:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Stop execution when workbook closes
On Error Resume Next
Application.OnTime Heure, "Calcul", , False
End Sub
Private Sub Workbook_Open()
'start execution when workbook opens
Application.OnTime Now + TimeValue("00:01:00"), "Calcul"
End Sub
In module :
VB:
Public Heure As Date
Sub Calcul()
Heure = Now + TimeValue("00:01:00")
Application.OnTime Heure, "Calcul"
Range("B65536").End(xlUp).Offset(1) = [A1]
End Sub
Cell A1 will be copied every minute in column B (starting B2). Now I want this function to start at 00:08:00 but wasn't able to achieve it.
As long as the workbook can remain open, the below code:
Private Sub Workbook_Open()
'start execution when workbook opens
Application.OnTime Now + TimeValue("00:01:00"), "Calcul"
End Sub
Can be replaced with the following:
Private Sub Workbook_Open()
'start execution at 8 AM when workbook opens
If Hour(Now()) < 8 Then
' If it is before 8 AM
Application.OnTime Int(Now()) + TimeSerial(8, 0, 0), "Calcul"
Else
' Otherwise begin 8 AM the next day
Application.OnTime Int(Now()) + 1 + TimeSerial(8, 0, 0), "Calcul"
End if
End Sub