How to execute VBA every 10 minutes?

lojanica

lojanica

New Member
Joined
Feb 22, 2024
Messages
34
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
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
See if this works for you. For testing purposes you can change the 10 minutes to say 10 seconds: ("00:00:10")

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

Application.OnTime Now + TimeValue("00:10:00"), "FilterUserTab"  '<-- this tells the macro, in 10 minutes run yourself again.

End Sub
 
Upvote 0
Logit said:
See if this works for you. For testing purposes you can change the 10 minutes to say 10 seconds: ("00:00:10")

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

Application.OnTime Now + TimeValue("00:10:00"), "FilterUserTab"  '<-- this tells the macro, in 10 minutes run yourself again.

End Sub
Click to expand...
Hi :)
Thanks for getting back!
I changed it to 10 sec for testing and it was working beautify
changed back to 10 minutes and ran the update a few times then stopped basically after the document was open for 30 min
 
Upvote 0
I was wanting to keep the timer approach as simple as possible but ...

So, let's try this :

VBA Code: 
Sub tmeMacro()
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.OnTime Now + TimeValue("00:00:10"), "FilterUserTab"
    End
    Application.DisplayAlerts = True
End Sub

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
    
    tmeMacro

End Sub
 
Upvote 0
Logit said:
I was wanting to keep the timer approach as simple as possible but ...

So, let's try this :

VBA Code: 
Sub tmeMacro()
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.OnTime Now + TimeValue("00:00:10"), "FilterUserTab"
    End
    Application.DisplayAlerts = True
End Sub

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
   
    tmeMacro

End Sub
Click to expand...
Saves the workbook but does not run "FilterUserTab"
Does it make any difference if there are multiple users in the document?
 
Upvote 0
lojanica said:
Saves the workbook but does not run "FilterUserTab"
Does it make any difference if there are multiple users in the document?
Click to expand...
or if I run "Sub tmeMacro()" it will work but will not do it every 10 seconds automatically
 
Upvote 0
I can't say for certain if more than one user has access at the same time. I can't replicate that environment here.

When you run "Sub tmeMacro()" ... what happens ?
 
Upvote 0
Logit said:
I can't say for certain if more than one user has access at the same time. I can't replicate that environment here.

When you run "Sub tmeMacro()" ... what happens ?
Click to expand...
It saves documents and does "FilterUserTab" but it would not repeat action in 10 sec
I have asked all to close the document and just opened it myself and same issues so it has nothing to do with extra users
 
Upvote 0
lojanica said:
It saves documents and does "FilterUserTab" but it would not repeat action in 10 sec
I have asked all to close the document and just opened it myself and same issues so it has nothing to do with extra users
Click to expand...
It saves documents and runs "FilterUserTab" but it would not repeat action in 10 sec
 
Upvote 0
Here is slightly different approach :

VBA Code: 
Dim TimeToRun

Sub ScheduleclrCol()
    TimeToRun = Now + TimeValue("00:00:10")     '<----- adjust time to fire here  HH:MM:SS
    Application.OnTime TimeToRun, "tmeMacro("
End Sub
 
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
598
Anthony47
A
lojanica
  • Solved
VBA code checks a condition, stops macro if FALSE, etc.
Replies
3
Views
431
Peter_SSs
Peter_SSs
lojanica
  • Solved
Filtering upon opening document without using VB code
Replies
1
Views
504
Joe4
Joe4
M
  • Solved
Replacing delete with a value
Replies
3
Views
396
Alex Blakenburg
A
D
  • Question Question
Generating Reports in Word Using Data in Excel
Replies
1
Views
408
Dan_W
D

Forum statistics

Threads
1,224,698
Messages
6,180,423
Members
452,981
Latest member
MarkS1234

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