你可以这样做
在本练习册上填写：

Private Sub Workbook_Open()

Call checkPW(True)

End Sub

然后在单独的模块中创建另外两个宏

Option Explicit

Sub checkPW(Optional firstRun As Boolean)

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 14) + TimeSerial(8, 49, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 15) + TimeSerial(8, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 16) + TimeSerial(8, 53, 0))

Dim PassWord As String 'User password

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
 
    End If

    Else:
    
    If firstRun = True Then
    MsgBox "Trial " & j & " has expired. New password will be required to continue"
    End If
        j = j + 1
End If

Call macro_timer

End Sub

Sub macro_timer()

'Tells Excel when to next run the macro.
Application.OnTime Now + TimeValue("00:00:10"), "checkPW"

End Sub

我以前

If firstRun = True Then
    MsgBox "Trial " & j & " has expired. New password will be required to continue"
    End If

要定义仅当打开工作簿时显示的内容，您可以根据需要进行调整

我认为这可能会起作用。我添加了另一个子例程，用于检查是否有任何工作表被更改或单元格被单击。然后，新的子Workbook_SheetChange检查相同的预定义日期，并调用原始的子Workbook_Open。因此，当工作簿打开时，用户将收到试用期已过期的消息，需要新密码才能开始下一次试用。以下是代码：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)

'This just needs to cont. checking the expiry date

ReDim ExpDate(1 To 3) As Date 'We pre-define the expiry dates

ExpDate(1) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 34, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 53, 0))

If CDate(Now) > ExpDate(1) And CDate(Now) < ExpDate(2) Then
   Workbook_Open
   ElseIf CDate(Now) > ExpDate(2) And CDate(Now) < ExpDate(3) Then
      Workbook_Open
      ElseIf CDate(Now) > ExpDate(3) Then
          Workbook_Open

End If

End Sub

Private Sub Workbook_Open()

Dim j, i, trials, passCnt As Integer
trials = 3 'Number of trials
passCnt = 4 'Number of times to enter password
j = 1
ReDim AllPassWords(1 To trials) As String
AllPassWords(1) = "123"
AllPassWords(2) = "456"
AllPassWords(3) = "789"

ReDim ExpDate(1 To trials) As Date 'We pre-define the expiry dates and passwords
ExpDate(1) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 34, 0))
ExpDate(2) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 51, 0))
ExpDate(3) = CStr(DateSerial(2023, 1, 13) + TimeSerial(18, 53, 0))

Dim PassWord As String

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 1 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j + 1
End If

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 2 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j + 1
End If

If CDate(Now) < ExpDate(j) Then 'If the jth trial has not expired we do the following

    If j = 3 Then
        For i = 1 To passCnt ' chances to enter password
            'Enter password before we can use the worksheet
            PassWord = InputBox("Please input password.")
            If PassWord = AllPassWords(j) Then
            
                Exit For
                
                ElseIf i < passCnt Then
                    MsgBox "Incorrect password. " & passCnt - i & " attempts remaining."
                
                ElseIf i = passCnt Then
                    MsgBox "Password limit reached. Closing workbook"
                    ThisWorkbook.Close
                
            End If
        Next i
    
    MsgBox ("You have " & ExpDate(j) - CDate(Now) & " days left")
        
    
    End If
    
    Else: MsgBox "Trial " & j & " has expired. New password will be required to continue"
        j = j + 1
End If

If j > trials Then
    'Here we have run out of all trials and we must end the function completely
    MsgBox "Trials have ended. Add-in will be terminated."
End If

  
End Sub