vba - 不活动后自动关闭工作簿

Question

我创建了一个宏，该宏可以在一段时间不活动后关闭WB。如果我手动打开文件，它会完美工作，但如果我使用不同 WB 中的另一个宏来打开文件，它不会在设置的不活动时间后自动关闭。我用来自动关闭它的代码是:

此工作簿模块:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    stop_Countdown
ThisWorkbook.Save
End Sub
Private Sub Workbook_Open()
    start_Countdown
    End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    stop_Countdown
    start_Countdown
    End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
    stop_Countdown
    start_Countdown
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
  ByVal Target As Excel.Range)
    stop_Countdown
    start_Countdown
End Sub

常规模块:

Option Explicit
Public Close_Time As Date
Sub start_Countdown()
    Close_Time = Now() + TimeValue("00:00:10")
    Application.OnTime Close_Time, "close_WB"
    End Sub
Sub stop_Countdown()
    Application.OnTime Close_Time, "close_WB", , False
    End Sub
Sub close_wb()
    ThisWorkbook.Close True
    End Sub

另一个宏的代码:

Sub Answer_Quote()

Worksheets("UI RM").Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, Password:="045"

 Dim wBook As Workbook
    On Error Resume Next
    Set wBook = Workbooks("Base de Datos Cotizaciones Shared.xlsb")

    If wBook Is Nothing Then 'Not open
            Set wBook = Nothing
            On Error GoTo 0
    Else 'It is open
            wBook.Close SaveChanges:=False
            Set wBook = Nothing
            On Error GoTo 0
    End If

Set wb4 = ActiveWorkbook
Range("AM7").Calculate
Range("K26:K28").Calculate
Dim arreglo(4) As Variant
arreglo(0) = Range("hour_sent").Value
arreglo(1) = Range("day_sent").Value
arreglo(2) = Range("respuesta").Value
arreglo(3) = Range("UsernameRM").Value

Dim Findwhat As String
Dim c, d, multirange As Range
Findwhat = Range("F11").Text

    Dim contador As Integer
    contador = 0
    While (IsFileOpen("\\3kusmiafs02\CARPETA COMERCIAL\Cotizaciones\Base de Datos Cotizaciones Shared.xlsb") And contador < 4)
        contador = contador + 1
        Application.Wait (Now + TimeValue("00:00:03"))
    Wend

    If contador = 4 Then
    MsgBox "La base de datos esta siendo utilizada por otro usuario. Por favor vuelva a intentarlo", vbExclamation, "Proceso cancelado"
    Exit Sub
    End If

Application.ScreenUpdating = False
Dim iStatus As Long
Err.Clear
On Error Resume Next
Set wb2 = Workbooks("Base de Datos Cotizaciones Shared.xlsb")
iStatus = Err
On Error GoTo 0
If iStatus Then 'workbook isn't open
Workbooks.Open filename:="\\3kusmiafs02\CARPETA COMERCIAL\Cotizaciones\Base de Datos Cotizaciones Shared.xlsb"
Else
'workbook is open
wb2.Activate
End If

On Error GoTo errHandler:

'Copy Hour Sent
Worksheets("Data").Activate
Set c = Range("A:A").Find(Findwhat, LookIn:=xlValues)
For j = 1 To 3
    c.Offset(0, 17 + j) = arreglo(j - 1)
Next j
c.Offset(0, 29) = arreglo(3)


'Save Database
Workbooks("Base de Datos Cotizaciones Shared.xlsb").Save
Workbooks("Base de Datos Cotizaciones Shared.xlsb").Close

    'Step-Back into User Interface
    wb4.Activate
    Worksheets("UI RM").Activate

    'Send E-Mail

    'Working in 2000-2010
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim response As Variant


    'Mail recipients

     Dim mail_recipients(3) As String

     'mail_recipients(1) = Range("email").Value
     'mail_recipients(2) = "mail"
     mail_recipients(3) = "mail2"


    'Source Set/Range selection

     Set Source = Nothing
     On Error Resume Next

    Worksheets.Add(After:=Worksheets("Interline Costs")).Name = "Quote Snap"

    'copy temp info
    Worksheets("UI RM").Activate
    Range("B7:G31").SpecialCells(xlCellTypeVisible).Select
    Application.CutCopyMode = False
    Selection.Copy
    Worksheets("quote snap").Activate
    Range("b2").Select
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveSheet.Paste

    'copy temp dims
    Worksheets("UI rm").Activate
    Range("I21:s33").SpecialCells(xlCellTypeVisible).Select
        Selection.Copy
    Worksheets("Quote Snap").Activate
    Range("H3").Select
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Columns("j:j").Select
    Selection.ColumnWidth = 12

    'select temp sheet
    Range("A1:V600").Select


Set Source = Selection.SpecialCells(xlCellTypeVisible)


    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    Source.Copy
    With Dest.Sheets(1)
        .Cells.Interior.Pattern = xlSolid
        .Cells.Interior.PatternColorIndex = xlAutomatic
        .Cells.Interior.ThemeColor = xlThemeColorDark1
        .Cells.Interior.TintAndShade = 0
        .Cells.Interior.PatternTintAndShade = 0
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False

    End With

    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Response to Quote #" & wb4.Worksheets("UI RM").Range("F11")

    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
        For i = 1 To 3
            .SendMail Recipients:=mail_recipients, _
                     Subject:="Response to Quote #" & wb4.Worksheets("UI RM").Range("quote_num") & " " & wb4.Worksheets("UI RM").Range("client") & " " & wb4.Worksheets("UI RM").Range("destination") & " " & wb4.Worksheets("UI RM").Range("total_KGS") & " KGS"

            If Err.Number = 0 Then Exit For
        Next i
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Application.DisplayAlerts = False
    wb4.Worksheets("quote snap").Delete
    Application.DisplayAlerts = True


MsgBox "Proceso Terminado"

wb4.Sheets("UI RM").Range("limpiar").ClearContents
wb4.Sheets("UI RM").Range("F29").ClearContents
wb4.Sheets("UI RM").Range("E43:I80").ClearContents

    'Starting Point
    wb4.Worksheets("UI RM").Activate
    Range("F11").Select

Application.Calculation = xlCalculationManual

Worksheets("UI RM").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="045"


Exit Sub

errHandler:

Dim wBook1 As Workbook
    On Error Resume Next
    Set wBook1 = Workbooks("Base de Datos Cotizaciones Shared.xlsb")

    If wBook1 Is Nothing Then 'Not open
            Set wBook1 = Nothing
            On Error GoTo 0
    Else 'It is open
            wBook1.Close SaveChanges:=False
            Set wBook1 = Nothing
            On Error GoTo 0
    End If
MsgBox "Hubo un error", vbExclamation, "Error"

End Sub

有什么想法吗？

Answer 1

正如 Susilo 在评论中指出的那样，问题肯定不是自动关闭代码本身，因为它可以工作。那么，“其他东西”可能就是 Answer_Quote() 代码，坦率地说，这是一团糟。我推荐以下内容:

使用虚拟代码

尝试运行一个虚拟宏(该宏实际上什么都不做，只是打开工作簿，在一段不活动后应自动关闭)而不是 Answer_Quote() 来查看问题是否仍然存在。如果没有，那么您就可以确定 Answer_Quote() 导致了问题。然后继续代码清理。

代码清理

1) 退出时将所有对象、外部文件和工作表引用设置为空。

可选，因此不太重要，但为了简化代码维护和调试，我还建议:

2)使用正确且一致的缩进

3)删除多余的代码行

例如:

If wBook Is Nothing Then 'Not open
        Set wBook = Nothing

如果它已经什么都没有，那么设置对什么都没有的引用显然是没有意义的。

4) 在顶部标注所有变量的尺寸，而不是在整个代码中标注尺寸。

5)使用显式选项(如果您还没有这样做)

测试自动关闭执行

代码清理后，再次测试。如果问题仍然存在，请尝试注释掉部分 Answer_Quote() 代码，然后重试。重复此过程，直到自动关闭执行再次起作用，并且您可以查明问题的确切原因。