从 Access 查询 Application.DisplayAlerts 导出数据时强制进入

Question

我们自动创建了 20 份左右的 Excel 报告，每天早上从启动 Access 中特定模块的任务管理器批处理文件运行。

将数据从 Access 查询（O365，版本 2310 内部版本 16924）导出到 Excel 模板 (xltm) 时，代码有时在第 10 次或第 15 次甚至最后一次时该行突出显示为黄色，就像我正在单步执行代码。

xl.Application.DisplayAlerts = False

没有错误或警报消息。

大多数时候它都有效。

按 F5 或 F8 单步执行代码有时会起作用，有时我必须重新启动整个过程。

无需进行 Office 或 Windows 更新，并且运行此软件的计算机没有问题。

Public Function _
  ExportToExcelTemplate _
  (QueryName As String, SaveAsFileName As String, Optional SaveAsPath As String = "TempFolder", _
  Optional TemplateFilePath As String = "", Optional ExcelSheetNum As Integer = 1, _
  Optional ExcelCell As String = "A2", Optional CloseFile As Boolean = False, _
  Optional ReportTitle As String = "", Optional PutDateInK1 As Boolean = True)
 
 'On Error Resume Next
 'DoCmd.SetWarnings False
    
    Dim rs As DAO.Recordset
    Dim xl As Excel.Application
    Dim xlwb As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim i As Long
    Dim InsertRange As String
    Dim xlrange As String
    Dim blnWasExcelOpen As Boolean


    If SaveAsPath = "TempFolder" Then
        SaveAsPath = Environ("Temp") & "\"
    End If


'check if SaveAsPath exists, if not exit sub
    If Dir(SaveAsPath, vbDirectory) = vbNullString Then
        GoTo Tidyup
    End If

'if excel is not open, then open it
    On Error Resume Next
    blnWasExcelOpen = True
    Set xl = GetObject(, "Excel.application")
    If xl Is Nothing Then
        blnWasExcelOpen = False
        Set xl = CreateObject("Excel.application")
        On Error GoTo 0
    End If


    xl.Application.DisplayAlerts = False
    xl.Application.ScreenUpdating = False


'Check if FilePath\SaveAsFileName is open or closed
    For i = xl.Workbooks.Count To 1 Step -1  ' if i<>0 then file is open
        If xl.Workbooks(i).Name = SaveAsFileName Then Exit For
    Next

    If TemplateFilePath = "" Then
        Set xlwb = xl.Workbooks.Open(SaveAsPath & SaveAsFileName) 'Open file, this will not error if already open
    Else

'check if template file path exists if so open it and save as
'Exit function if template file path does not exist or Save as file is already open
        
        If Dir(TemplateFilePath) = vbNullString Or i <> 0 Then
            GoTo Tidyup
        Else
            Set xlwb = xl.Workbooks.Open(TemplateFilePath)
            xlwb.SaveAs SaveAsPath & SaveAsFileName, 51 '51 is xlsx, 52 is xlsm
        End If
    End If
  

    Set xlSheet = xlwb.Sheets(ExcelSheetNum)

    Set rs = CurrentDb.OpenRecordset(QueryName)

    rs.MoveLast
    rs.MoveFirst

    If rs.RecordCount > 2 Then
        xlSheet.Activate
        xlSheet.Range(ExcelCell).Offset(1, 0).Activate
        InsertRange = xl.Selection.Address & ":" & xl.Selection.Offset(rs.RecordCount - 3, rs.Fields.Count).Address
        xlSheet.Range(InsertRange).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If


'Move to first cell in spreadsheet and scroll to left
    xl.Application.GoTo Reference:=xlSheet.Range("A1"), Scroll:=True

'Add Date to Report
    If PutDateInK1 Then
        If xlSheet.Range("K1").Value <> "" Then
            xlSheet.Range("K1").Value = Date
        End If
    End If

'Create dummy worksheet for better paste results on date formatting'

    xl.Sheets.Add.Name = "DummyWorkSheet"
    xl.Sheets("DummyWorkSheet").Select
    
    xlSheet.Range(ExcelCell).CopyFromRecordset rs
    If ReportTitle <> "" Then
        xlSheet.Range("A1").Value = ReportTitle
    End If
    
    xl.Sheets("DummyWorkSheet").Delete

'Move to First sheet in workbook
    xl.Sheets(1).Select
    xl.Visible = True
    xlwb.Save
    
Tidyup:
    xl.Application.DisplayAlerts = True
    xl.Application.ScreenUpdating = True
    
    If CloseFile = True Then
        xlwb.Close
        If blnWasExcelOpen = False Then
        xl.Quit
        End If
    End If
    
    
    Set rs = Nothing
    Set xl = Nothing
    Set xlwb = Nothing
    Set xlSheet = Nothing

'DoCmd.SetWarnings True

End Function

Answer 1

这些是我留给同事的关于此类错误的注释：

因此，工作了数天、数月、数周甚至数年的东西突然产生此错误消息“代码执行已被中断”

您已经好几个月没有使用 Ctrl-C 或 Ctrl-Pause/Break 了，但它就在这里。随机的。

解决方案：解决方案是单击“调试”，然后按 Ctrl-Pause/Break 两次。 F5 运行至完成。保存工作簿。打开。再试一次。 魔法。我没有骗你

或

另一个，有些东西已经工作了好几天等等，但现在随机停在一行代码上。没有错误消息，没有解释。 通常，这将是您过去有断点的地方，但现在不存在了。

要尝试的事情

1. 关闭 Excel 并重新打开。再次尝试运行。有时有效
2. 在该行上放置一个断点 (F9)，然后再次将其取消。再次尝试运行。有时有效
3. 调试，清除所有断点（Ctrl-Shift-F9）。再次尝试运行。通常有效
4. 进行细微更改（例如删除一个字符，重新输入该字符，单击另一行）。调试、编译VBA项目。保存工作簿并退出。再次尝试运行。总是有效，但是 PITA

或

1. 将所有代码模块导出到文本文件
2. 删除所有代码模块
3. 保存并退出
4. 导入所有代码模块
5. 编译
6. 保存并退出
7. 再试一次