闲置后自动closures工作簿
我创build了一个在一段时间不活动后closuresWB的macros。 如果我手动打开文件，它是完美的，但如果我使用另一个WB中的另一个macros来打开文件，在设置的非活动时间后它不会自动closures。 我用来自动closures它的代码是：
此工作簿模块：
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
另一个macros的代码：
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
有任何想法吗？
正如Susilo在评论中指出的那样，这个问题必须是自动closures代码本身以外的东西，因为它是有效的。 那个“别的东西”可能就是Answer_Quote()代码，坦率的说是一团糟。 我build议如下：
使用虚拟代码
尝试运行一个虚拟macros（一个本质上什么都不做，但打开工作簿后应该自动closures的macros）而不是Answer_Quote()来查看问题是否存在。 如果没有，那么你肯定知道Answer_Quote()是造成这个问题的原因。 继续进行代码清理。
代码清理
1）退出时将所有对象，外部文件和图纸引用设置为空。
可选地，因此不那么重要，但为了简化代码维护和debugging，我还build议：
2）使用适当和一致的缩进
3）删除多余的代码行
例如：
If wBook Is Nothing Then 'Not open Set wBook = Nothing
如果已经什么都没有了，那么把一无所有的东西放在一个没有意义的地方是毫无意义
4）在顶部而不是在整个代码中标注所有variables。
5）使用Option explicit （如果你还没有）
testing自动closures执行
代码清理后，再次testing。 如果问题仍然存在，请尝试注释掉某些Answer_Quote()代码，然后重试。 重复此过程，直到自动closures执行再次运行，您可以确定问题的确切原因。
尝试添加一个停止语句到您的workbook_open来testing事件是否被触发
Private Sub Workbook_Open() start_Countdown Stop End Sub
这将是一个蛮力的方式来从调用工作簿运行开放的事件。
Application.Run(ActiveWorkbook.name & "!Workbook_Open")
在打开工作簿后添加。