How to execute VBA every 10 minutes?

lojanica

lojanica

New Member
Joined
Feb 22, 2024
Messages
39
Office Version
  1. 365
Platform
  1. Windows
My VBA code is in Module 1 and instead of exciting it manually and on opening of document only I would like to have it execute every 10 min while the document is open. Also, a document is opened by several people at the same time.
Can anyone help with this?

The code below is the one I am looking to execute every 10 min. This is currently being done by opening the document and manually executing it.

VBA Code: 
Sub FilterUserTab()

 Dim mainwb As Workbook
    Dim usernameSheetName As String
    Dim targetSheet As Worksheet

' Below code is to update new and closed jobs
        
     Set mainwb = ActiveWorkbook
    Set flowDataSheet = mainwb.Sheets("FlowData")
    Set registerSheet = mainwb.Sheets("AMSI-R-102 Job Request Register")
    
    ' Check if the worksheet has autofilter applied
    registerSheet.Activate
    If registerSheet.AutoFilterMode Then
        registerSheet.AutoFilter.ShowAllData
    End If
    
     ' Set references to the ListObject and columns in FlowData sheet
    flowDataSheet.Activate
    Set table1 = flowDataSheet.ListObjects("Table1")
    Set indexColumn = table1.ListColumns("index").DataBodyRange
    Set jobNoColumn = table1.ListColumns("Job No.:").DataBodyRange
    
    ' Loop through each row in the index column of Table1
    
    For i = 1 To indexColumn.Rows.Count
        Set flowDataRow = indexColumn.Cells(i)
        ' Check if the cell in the index column is empty or contains a formula that returns an empty value
        If IsEmpty(flowDataRow.Value) Or flowDataRow.Value = "" Then
            ' Find the corresponding Job No. value in the same row of the table1 in flowdata sheet
            jobNo = jobNoColumn.Cells(flowDataRow.Row - indexColumn.Row + 1).Value
            ' Find the last used row in column B of the register sheet
            lastRow = registerSheet.Cells(registerSheet.Rows.Count, "B").End(xlUp).Row
            ' Copy the Job No. value to the last row + 1 in column B of the register sheet
            'registerSheet.Cells(lastRow + 1, "B").Value = jobNo
            registerSheet.Cells(lastRow + 1, "B").Formula = "=HYPERLINK('FlowData'!P" & i + 1 & ",'FlowData'!B" & i + 1 & ")"
        End If
    Next i
' Update new and closed jobe done next step is Filter user tab
       
    ThisWorkbook.Sheets("AMSI-R-102 Job Request Register").Range("B6").Value = Environ("USERNAME")
    Set mainwb = ActiveWorkbook
    usernameSheetName = mainwb.Sheets("AMSI-R-102 Job Request Register").Range("B6").Value
        
    On Error Resume Next
    Set targetSheet = mainwb.Sheets(usernameSheetName)
    On Error GoTo 0
    
    If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        Exit Sub
    End If

    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
    End If

    Range("A8:N8").AutoFilter Field:=13, Criteria1:=Range("B6")
    Range("A8:N8").AutoFilter Field:=12, Criteria1:="In progress"
    
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Range("A8:N" & lastRow).Sort Key1:=Range("F8:F" & lastRow), Order1:=xlAscending, Header:=xlNo

End Sub
 
Sort by date Sort by votes
Go ahead and click on that to enable the macros. Then if you go to the upper left corner of the Excel workbook, click the Excel button and then click on "Excel Options".
Then go to "Trust Center" ... then "Trust Center Settings". Then click on "Enable all macros". That is the only setting that will work for running macros and not being
pestered with those agitating pop-up notices/warnings.

It is late here (western North Carolina).

I suspect there is something amiss in the code within the macro "FilterUserTab" and it is not throwing an error message to let you know where it is freezing up Excel.
If you place your cursor at the beginning of the macro "FilterUserTab", then one by one, press the F8 key Excel will step through the macro code and simulate running
it. If there is an error it will be found prior to Excel getting to the end of the macro. With that information we can work further on this issue.
 
Upvote 0

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try this Access file
1734500411780.png

Just write the name of the procedure, the interval and select a file from the list. Then, just click start and it will run that procedure.

RunExcelProcedureOnTimer.accdb

drive.google.com drive.google.com

In case anyone is wondering, the code looks like this in Access:
VBA Code: 
Option Compare Database
Option Explicit

Private counter As Long

Private Sub Comando14_Click()
    counter = 0
    
    Dim interval As Long
    interval = Nz(Me.Texto12.Value, 0)
    
    If IsNumeric(Me.Texto12) Then
        Me.TimerInterval = Me.Texto12
    Else
        Me.TimerInterval = 0
    End If
End Sub

Private Sub Comando15_Click()
    Me.TimerInterval = 0
End Sub

Private Sub Comando4_Click()
    PopulateListbox
End Sub

Private Sub Form_Load()
    Me.TimerInterval = 0
    PopulateListbox
End Sub

Private Sub PopulateListbox()
    
    Dim instancesCollection As New Collection
    Set instancesCollection = GetExcelInstances
    
    Dim cleanupDictionary As Object
    Set cleanupDictionary = CreateObject("Scripting.Dictionary")
    
    Lista0.ColumnCount = 2
    Lista0.ColumnWidths = "7 in; 1 in"
    Lista0.RowSource = ""
    
    Dim instance As Object, wb As Object
    For Each instance In instancesCollection
        For Each wb In instance.workbooks
            If Not cleanupDictionary.exists(wb.FullName) Then
                cleanupDictionary.Add wb.FullName, wb.sheets.Count
                Lista0.AddItem wb.FullName & ";" & wb.sheets.Count & " sheets"
            End If
        Next wb
    Next instance
    
End Sub

Private Sub Form_Timer()

    If Not IsNull(Lista0.Value) Then
        counter = counter + 1
    
        Dim procedure As String
        procedure = Nz(Me.Texto10.Value, "")
    
    
        Dim wb As Object
        Set wb = GetObject(Lista0.Value)
        
        Dim fileName As Variant
        fileName = Split(Lista0.Value, "\")
        
        wb.Parent.Run "'" & fileName(UBound(fileName)) & "'!" & procedure
        
        Me.Texto16.Value = procedure & " has run " & counter & " times"
    End If

End Sub

I used Access because its forms have a timer and it's convenient for this.
 
Upvote 0
This information was passed along from a friend :

I don't know if this will be the reason, but....
You have this condition:



VBA Code: 
If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        Exit Sub
    End If

If targetSheet is Nothing, the procedure is exited without setting OnTime again.
 
Upvote 0
You could amend your code to this :

Code: 
 If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        TimeToRun
        
        'Exit Sub
        
    End If
 
Upvote 0
Logit said:
You could amend your code to this :

Code: 
 If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        TimeToRun
      
        'Exit Sub
      
    End If
Click to expand...
Happy New Year :)

Change the code like this?
VBA Code: 
Sub ScheduleclrCol()

Dim TimeToRun

    TimeToRun = Now + TimeValue("00:00:10")     '<----- adjust time to fire here  HH:MM:SS
    
    '##############################################################################################################################
    
    Application.OnTime TimeToRun, "FilterUserTab"   '<----------------------------------------- I changed the macro reference here.
    
    '##############################################################################################################################
    If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        Exit Sub
    End If
    
End Sub
 
Upvote 0
lojanica said:
Happy New Year :)

Change the code like this?
VBA Code: 
Sub ScheduleclrCol()

Dim TimeToRun

    TimeToRun = Now + TimeValue("00:00:10")     '<----- adjust time to fire here  HH:MM:SS
   
    '##############################################################################################################################
   
    Application.OnTime TimeToRun, "FilterUserTab"   '<----------------------------------------- I changed the macro reference here.
   
    '##############################################################################################################################
    If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        Exit Sub
    End If
   
End Sub
Click to expand...
The "targetSheet" comes back as a variable not found after completing the code
 
Upvote 0
Change target.sheet to the name of the actual sheet you want to activate.
 
Upvote 0
Logit said:
Change target.sheet to the name of the actual sheet you want to activate.
Click to expand...
the filter user code determines the sheet, as it follows the username opening document so i dont this this will work
 
Upvote 0
Edgar_ said:
Try this Access file
View attachment 120454
Just write the name of the procedure, the interval and select a file from the list. Then, just click start and it will run that procedure.

RunExcelProcedureOnTimer.accdb

drive.google.com drive.google.com

In case anyone is wondering, the code looks like this in Access:
VBA Code: 
Option Compare Database
Option Explicit

Private counter As Long

Private Sub Comando14_Click()
    counter = 0
   
    Dim interval As Long
    interval = Nz(Me.Texto12.Value, 0)
   
    If IsNumeric(Me.Texto12) Then
        Me.TimerInterval = Me.Texto12
    Else
        Me.TimerInterval = 0
    End If
End Sub

Private Sub Comando15_Click()
    Me.TimerInterval = 0
End Sub

Private Sub Comando4_Click()
    PopulateListbox
End Sub

Private Sub Form_Load()
    Me.TimerInterval = 0
    PopulateListbox
End Sub

Private Sub PopulateListbox()
   
    Dim instancesCollection As New Collection
    Set instancesCollection = GetExcelInstances
   
    Dim cleanupDictionary As Object
    Set cleanupDictionary = CreateObject("Scripting.Dictionary")
   
    Lista0.ColumnCount = 2
    Lista0.ColumnWidths = "7 in; 1 in"
    Lista0.RowSource = ""
   
    Dim instance As Object, wb As Object
    For Each instance In instancesCollection
        For Each wb In instance.workbooks
            If Not cleanupDictionary.exists(wb.FullName) Then
                cleanupDictionary.Add wb.FullName, wb.sheets.Count
                Lista0.AddItem wb.FullName & ";" & wb.sheets.Count & " sheets"
            End If
        Next wb
    Next instance
   
End Sub

Private Sub Form_Timer()

    If Not IsNull(Lista0.Value) Then
        counter = counter + 1
   
        Dim procedure As String
        procedure = Nz(Me.Texto10.Value, "")
   
   
        Dim wb As Object
        Set wb = GetObject(Lista0.Value)
       
        Dim fileName As Variant
        fileName = Split(Lista0.Value, "\")
       
        wb.Parent.Run "'" & fileName(UBound(fileName)) & "'!" & procedure
       
        Me.Texto16.Value = procedure & " has run " & counter & " times"
    End If

End Sub

I used Access because its forms have a timer and it's convenient for this.
Click to expand...
The Access is not supported in our company, unfortunately, howver thanks for trying to help
 
Upvote 0
I have made the following changes and it is working perfectly :)
Module 1 code:

VBA Code: 
Sub ScheduleclrCol()

Dim TimeToRun

    TimeToRun = Now + TimeValue("00:10:00")     '<----- adjust time to fire here  HH:MM:SS
    
    '##############################################################################################################################
    
    Application.OnTime TimeToRun, "ScheduleclrCol"  '<----------------------------------------- I changed the macro reference here.
    
    '##############################################################################################################################
    Call FilterUserTab '<----------------------------------------- This will run v every 10 min to update jobs
      
End Sub



Sub FilterUserTab()

Dim mainwb As Workbook
    Dim usernameSheetName As String
    Dim targetSheet As Worksheet
    Dim flowDataSheet As Worksheet
    Dim registerSheet As Worksheet
    Dim table1
    Dim indexColumn
    Dim jobNoColumn
    Dim i As Long
    Dim flowDataRow
    Dim jobNo As Long
    Dim lastRow As Variant

' Below code is to update new and closed jobs
        
     Set mainwb = ActiveWorkbook
    Set flowDataSheet = mainwb.Sheets("FlowData")
    Set registerSheet = mainwb.Sheets("AMSI-R-102 Job Request Register")
    
    ' Check if the worksheet has autofilter applied
    registerSheet.Activate
    If registerSheet.AutoFilterMode Then
        registerSheet.AutoFilter.ShowAllData
    End If
    
     ' Set references to the ListObject and columns in FlowData sheet
    flowDataSheet.Activate
    Set table1 = flowDataSheet.ListObjects("Table1")
    Set indexColumn = table1.ListColumns("index").DataBodyRange
    Set jobNoColumn = table1.ListColumns("Job No.:").DataBodyRange
    
    ' Loop through each row in the index column of Table1
    
    For i = 1 To indexColumn.Rows.Count
        Set flowDataRow = indexColumn.Cells(i)
        ' Check if the cell in the index column is empty or contains a formula that returns an empty value
        If IsEmpty(flowDataRow.Value) Or flowDataRow.Value = "" Then
            ' Find the corresponding Job No. value in the same row of the table1 in flowdata sheet
            jobNo = jobNoColumn.Cells(flowDataRow.Row - indexColumn.Row + 1).Value
            ' Find the last used row in column B of the register sheet
            lastRow = registerSheet.Cells(registerSheet.Rows.Count, "B").End(xlUp).Row
            ' Copy the Job No. value to the last row + 1 in column B of the register sheet
            'registerSheet.Cells(lastRow + 1, "B").Value = jobNo
            registerSheet.Cells(lastRow + 1, "B").Formula = "=HYPERLINK('FlowData'!P" & i + 1 & ",'FlowData'!B" & i + 1 & ")"
        End If
    Next i
' Update new and closed jobe done next step is Filter user tab
      
    ThisWorkbook.Sheets("AMSI-R-102 Job Request Register").Range("B6").Value = Environ("USERNAME")
    Set mainwb = ActiveWorkbook
    usernameSheetName = mainwb.Sheets("AMSI-R-102 Job Request Register").Range("B6").Value
        
    On Error Resume Next
    Set targetSheet = mainwb.Sheets(usernameSheetName)
    On Error GoTo 0
    
    If Not targetSheet Is Nothing Then
        targetSheet.Activate
    Else
        mainwb.Sheets("AMSI-R-102 Job Request Register").Activate
        Exit Sub
    End If

    If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
    End If

    Range("A8:N8").AutoFilter Field:=13, Criteria1:=Range("B6")
    Range("A8:N8").AutoFilter Field:=12, Criteria1:="In progress"
    
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Range("A8:N" & lastRow).Sort Key1:=Range("F8:F" & lastRow), Order1:=xlAscending, Header:=xlNo
    
    
   '##############################################################################################################################
    
    ScheduleclrCol          '<----------------------------- I changed the macro reference here.
    
    '##############################################################################################################################
   

End Sub


Thisworkbook window code:
VBA Code: 
Private Sub Workbook_Open()
Call ScheduleclrCol
End Sub

Thank you for all help!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

lojanica
  • Question Question
VBA to autosave and close after a set amount of time
Replies
3
Views
640
Anthony47
A
lojanica
  • Solved
VBA code checks a condition, stops macro if FALSE, etc.
Replies
3
Views
441
Peter_SSs
Peter_SSs
lojanica
  • Solved
Filtering upon opening document without using VB code
Replies
1
Views
513
Joe4
Joe4
V
  • Solved
Optimizing VBA for Speed
2
Replies
17
Views
3K
DanteAmor
DanteAmor
A
  • Question Question
Page break issues when exporting to pdf from userform (VBA)
Replies
0
Views
908
auglocqnuk
A

Forum statistics

Threads
1,225,619
Messages
6,186,045
Members
453,335
Latest member
sfd039

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top