Я работаю над файлом Excel с макросами, который я хочу работать как расписание. Там есть кнопка, которую пользователь нажмет, и текущее время будет проставлено в стартовом столбце; если пользователь нажимает его снова, текущее время будет проставлено в столбце финиша. Если пользователь запустил цикл, а ПК работает 5 минут без взаимодействия с пользователем, цикл будет завершен, и время будет автоматически указано в ячейке финиша. Когда цикл запущен, запускается таймер на 5 минут. Если до истечения 5-минутного таймера нет активности на компьютере, будет проставлено время и цикл закончится.
Код обнаруживает неактивность ПК, а не только в Excel.
Когда я открываю или работаю с другой книгой, макрос / таймер останавливается. Мне нужен макрос для продолжения работы, даже если я работаю над другим файлом Excel.
Я пробовал обходной путь DoEvents, но он не работал. Я читал, что есть ошибка при использовании Workbook.Open, но я не использовал Workbook.Open ни в одном из своих модулей. Когда я открываю другой файл Excel, он просто находит файл на рабочем столе и дважды щелкает по нему.
Я пытался объявить глобальную переменную, чтобы получить и сохранить имя листа (потому что другие люди будут делать его копии и использовать его, имя листа, скорее всего, будет изменено), потому что я Я чувствую, что это как-то связано с моим кодом, который идентифицирует активную ячейку.
Лист1
Dim mRg As Range
Dim mStr As String
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("A:A"), Target)
xOffsetColumn = 5
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Date
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
'Locking the entire third column with a password
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Range("C:C"), Target)
If xRg Is Nothing Then Exit Sub
Target.Worksheet.Unprotect Password:="password"
If xRg.Value <> mStr Then xRg.Locked = True
Target.Worksheet.Protect Password:="password"
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Range("C:C"), Target) Is Nothing Then
Set mRg = Target.Item(1)
mStr = mRg.Value
End If
End Sub
ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lA As Long
'Last non-blank cell of column A (Start)
Dim lB As Long
'Last non-blank cell of column B (Finish)
lA = Cells(Rows.Count, 1).End(xlUp).Row
lB = Cells(Rows.Count, 2).End(xlUp).Row
If lA <> lB Then
'If there's an unfinished cycle, execute the following:
Call Range_End_Method
Call TimeStartStop
ThisWorkbook.Save
Application.DisplayAlerts = False
End If
If lA = lB Then
'If there's no unfinished cycle, save the sheet and immediately close the sheet
ThisWorkbook.Save
Application.DisplayAlerts = False
End If
End Sub
Модуль 1
Option Explicit
Sub Range_End_Method()
'Finds the last non-blank cell in a single row or column
Dim FirstBlankCell As Range
Set FirstBlankCell = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
FirstBlankCell.Activate
End Sub
Module2
Private Type LASTINPUTINFO
cbSize As Long
dwTime As Long
End Type
Private Declare PtrSafe Function GetLastInputInfo Lib "user32" (lii As LASTINPUTINFO) As Long
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
'Getting number of seconds idle/user inactivity on PC, not just Excel
Private Function GetIdleSecs()
Dim LastInput As LASTINPUTINFO
With LastInput
.cbSize = Len(LastInput)
Call GetLastInputInfo(LastInput)
GetIdleSecs = (GetTickCount() - .dwTime) / 1000
End With
End Function
Public Sub checkIdle()
Dim lA As Long
'Last non-blank cell of column A (Start)
Dim lB As Long
'Last non-blank cell of column B (Finish)
lA = Cells(Rows.Count, 1).End(xlUp).Row
lB = Cells(Rows.Count, 2).End(xlUp).Row
'If block for if the sheet is blank
If lA = 4 Then
lA = 6
End If
If lB = 4 Then
lB = 6
End If
DoEvents
'Number of seconds idle
Dim idleSecs As Long: idleSecs = GetIdleSecs()
If lA <> lB Then
'If there's a running cycle, execute the following
'For Debugging purposes; this shows up in the immediate Window which you can open by pressing Ctrl + G
Debug.Print "Idle for"; idleSecs
'If number of seconds idle is less than 5 minutes, the timer will continue counting and updating every second
If idleSecs < 300 Then
Application.OnTime Now + TimeValue("00:00:01"), "checkIdle", False
End If
'idleSecs is the number of seconds needed before the whole If Block is executed
'300 seconds because 5 minutes x 60 seconds
If idleSecs = 300 Then
Call Module1.Range_End_Method
Call Module3.TimeStartStop
'Save the current workbook
ThisWorkbook.Save
'Message box: First parameter is the message body, third parameter is the alert title
MsgBox "TMS has stopped due to 5 minutes of inactivity. Your workbook has automatically been updated and saved.", , "TMS Stopped"
'Sub is automatically closed once 5 minutes is reached and the timer is stopped
Exit Sub
End If
End If
If lA = lB Then
'If there's no running cycle, execute the following:
'For debugging purposes
'Debug.Print "Doing nothing..."
End If
End Sub
Public Sub doNothing()
'For debugging purposes
'Debug.Print "Doing nothing..."
End Sub
Module3
Sub TimeStartStop()
CR = ActiveCell.Row
CC = ActiveCell.Column
If CC <= 2 And CR >= 6 Then
TS = ThisWorkbook.ActiveSheet.Name
ThisWorkbook.Sheets(TS).Cells(CR, CC) = Now
ThisWorkbook.Sheets(TS).Cells(CR, CC + 1).Select
If CC = 2 And ThisWorkbook.Sheets(TS).Cells(CR, 1) <> "" Then
ActiveCell.FormulaR1C1 = _
"=IFS(RC[-2] = """","""",((RC[-1]-RC[-2])*24*60)<0,"""",(RC[-1]-RC[-2])*24*60,(RC[-1]-RC[-2])*24*60)"
'ThisWorkbook.ActiveSheet.Cells(CR, 3) = _
' (ThisWorkbook.ActiveSheet.Cells(CR, 2) - ThisWorkbook.ActiveSheet.Cells(CR, 1)) * 24 * 60
ThisWorkbook.Sheets(TS).Cells(CR + 1, CC - 1).Select
End If
End If
End Sub
Module4
Sub StartStopButtonClick()
'Macro assigned to the Start/Stop button. Automatically executes the TimeStartStop and checkIdle subs upon being clicked
Dim lA As Long
'Last non-blank cell of column A (Start)
Dim lB As Long
'Last non-blank cell of column B (Finish)
Dim lC As Long
'The next blank cell right below lA
lA = Cells(Rows.Count, 1).End(xlUp).Row
lB = Cells(Rows.Count, 2).End(xlUp).Row
lC = lA + 1
If lA = 4 Then
'For a completely blank file
lA = 6
lB = 6
Cells(lA, 1).Select
ElseIf lA <> lB Then
'If there's an unfinished cycle, go to the Finish cell
Cells(lA, 2).Select
ElseIf lA = lB Then
'If there are no running cycles, go to the next empty Start cell
Cells(lC, 1).Select
Else:
Debug.Print "Call Tech Support"
End If
'Execute the following modules:
Call Module3.TimeStartStop
Call Module2.checkIdle
End Sub
Так выглядит лист.
Ячейки в столбце C (время цикла) должны блокироваться после ввода данных в них с помощью макроса (который рассчитывает время цикла с использованием времени начала и окончания).
По общему признанию, удаление / избавление от рядов является болью в заднице. Я должен был сделать руководство пользователя, которое послужило бы руководством для этого.
Все отлично работает , просто , когда я переключаюсь на другой файл Excel (даже если он был открыт ранее), таймер останавливается .
Мне бы хотелось, чтобы макрос продолжал работать, даже если пользователь переключается на другой файл Excel или открывает новый файл Excel.
Заранее большое спасибо!