Setting VBA to automatically run when the spreadsheet is opened first time ONLY-CodePudding

I need your help please.

I only want the macro to run when the spreadsheet is opened the first time each day. The reason for this is multiple people will open the spreadsheet throughout the day and I don't want it running every time someone opens the file. It's currently set to run 1 minute after each time it's opened and that does work.

This is what I have so far -

In a Module:

Sub SingleLevelSort()

ActiveSheet.Unprotect Password:="VANS01"

Worksheets("Portfolio Tracker").Sort.SortFields.Clear
 
Range("A2:BA5000").Sort Key1:=Range("F3"), Header:=xlYes

ActiveSheet.Protect Password:="VANS01", AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True, DrawingObjects:=True, Scenarios:=False, AllowDeletingRows:=True

Call Workbook_Open

End Sub

Private Sub Workbook_Open()

Application.OnTime Now   TimeValue("00:01:00"), "SingleLevelSort"

End Sub

In this WorkBook:

Private Sub Workbook_Open()

Application.OnTime Now   TimeValue("00:01:00"), "SingleLevelSort"

End Sub

CodePudding user response：

So, you can have a hidden sheet where every time the user opens the workbook, the code searches for 1 against today's date and if the both the conditions are satisfied, it will not run the code. In case, the given date is not today's date, it will overwrite the cell value with today's date.

You can use the below code but make sure to add today's date in Range("A1") and 1 in Range("B1")

Private Sub Workbook_Open()

Dim ws as worksheet

Set ws = Thisworkbook.Worksheet("Sheet1") ' add your hidden sheet name in place of sheet1

If Cells(1,1).value <> Date() then
ws.Cells(1,1).value = Date()
ws.Cells(1,2).value = "1"
Application.OnTime Now   TimeValue("00:01:00"), "SingleLevelSort"
Else
Exit  sub
End if
End Sub

Let me know if you need any clarification with the code.

CodePudding user response：

One solution is to add a Name to the Application.Names collection which can be tested upon the Workbook being opened.

Placed in ThisWorkbook

Private Sub Workbook_Open()
    Run "RunOnceDaily"
End Sub

Placed in a Module

Sub RunOnceDaily()
On Error GoTo ExitSub
    
    Dim LastDayRun As String
    Dim Today As String: Today = Replace(Trim(Date), "/", "") ' Date is an internal function
    
    For Each Item In Application.Names
        If Left(Item.Name, 10) = "LastRunDay" Then
            LastDayRun = Item.Name
            'Application.Names.Item(Item.Name).Delete  ' use to reset Workbook (comment loop block below out)
        End If
    Next
    If Right(LastDayRun, Len(Today)) <> Today Or LastDayRun = "" Then
        Call RunDaily
        Call Application.Names.Add("LastRunDay" & Today, RefersTo:=True, Visible:=False)
        If LastDayRun <> "" Then Application.Names.Item(LastDayRun).Delete
        Application.DisplayAlerts = False
            ThisWorkbook.Save
        Application.DisplayAlerts = True
    End If
    'Debug.Print "Macro Processed"

ExitSub:
End Sub

Private Function RunDaily()
    Debug.Print "Run Once Daily Completed"
End Function

You may want to move the Name addition and saving of the workbook to the RunDaily function so it only gets added once that macro has been fully completed (you could pass in the Today string for it)

CodePudding user response：

Sub Workbook_Open()
    ' First, you want to get the utc
    ' regardless of user localization.
    ' https://stackoverflow.com/a/1600912/5332500
    
    Dim dt As Object, utc As Date
    Set dt = CreateObject("WbemScripting.SWbemDateTime")
    dt.SetVarDate Now
    utc = DateValue(dt.GetVarDate(False))
    
    ' Then check if the wb has been opened today
    If ThisWorkbook.Names("LastOpenedOn") = "=" & CLng(utc) Then
        Debug.Print "wb was opened."
    Else
        ThisWorkbook.Names("LastOpenedOn").RefersTo = utc
        Debug.Print "wb opened first time today."
        
        ' Finally you should save the workbook immediately
        ' after running the macro first time for the day.
        ThisWorkbook.Save
    End If
        
End Sub