將VBA設定為僅在第一次打開電子表格時自動運行

我需要你的幫助。

我只希望在每天第一次打開電子表格時運行宏。這樣做的原因是多人將全天打開電子表格，我不希望每次有人打開檔案時它都運行。它目前設定為每次打開后運行 1 分鐘，并且確實有效。

這是我到目前為止所擁有的 -

在一個模塊中：

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

在本作業簿中：

Private Sub Workbook_Open()

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

End Sub

uj5u.com熱心網友回復：

因此，您可以有一個隱藏的作業表，每次用戶打開作業簿時，代碼都會針對今天的日期搜索 1，如果兩個條件都滿足，它將不會運行代碼。如果給定日期不是今天的日期，它將用今天的日期覆寫單元格值。

您可以使用以下代碼，但請確保在 Range("A1") 中添加今天的日期，在 Range("B1") 中添加 1

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 

如果您需要對代碼進行任何說明，請告訴我。

uj5u.com熱心網友回復：

一種解決方案是向集合中添加一個Name，Application.Names可以在打開作業簿時對其進行測驗。

放入本作業簿

Private Sub Workbook_Open()
    Run "RunOnceDaily"
End Sub

放置在一個模塊中

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

您可能希望將Name作業簿的添加和保存移動到RunDaily函式中，以便僅在該宏完全完成后才添加它（您可以Today為其傳遞字串）

uj5u.com熱心網友回復：

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

標籤：擅长 vba

上一篇：下標超出范圍，將一個作業簿中的范圍復制到另一個作業簿

下一篇：ExcelVBA-DoWhile回圈-單元格中的日期