代码之家 › 专栏 › 技术社区 › allthem

将VBA设置为仅在第一次打开电子表格时自动运行

macros vba excel

allthem · 技术社区 · 3 年前

我只想在每天第一次打开电子表格时运行宏。原因是一天中会有多人打开电子表格,我不希望每次有人打开文件时它都运行。目前,它被设置为每次打开后运行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

0 回复 | 直到 3 年前

Sanjanajaggi 3 年前

因此,您可以有一个隐藏的工作表,用户每次打开工作簿时,代码都会根据今天的日期搜索1,如果两个条件都满足,则不会运行代码。如果给定的日期不是今天的日期,它将用今天的日期覆盖单元格值。

您可以使用下面的代码,但请确保在中添加今天的日期范围(“A1”)和范围(“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

如果您需要对代码进行任何澄清,请告诉我。

Tragamor 3 年前

一个解决方案是添加 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

你可能想移动 名称 将工作簿添加并保存到 RunDaily 函数,这样它只在宏完全完成后才被添加(您可以传入 Today (用字符串表示)

Rosetta 3 年前

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