Excel VBA窗体连接外部工作簿 匹配校验失效、卡死问题求助

问题根因汇总 #

• 调用Match函数时用了当前宿主Excel的Application对象，而查找的数据在新建的隐藏Excel实例的工作簿里，跨进程调用直接导致匹配逻辑完全失效，严重时会触发无响应
• 文件占用判断逻辑有两处硬错误：一是打开被占用文件时系统默认会弹提示框，隐藏的Excel实例没法响应该弹窗直接卡死；二是消息框常量拼错，vbookonly是不存在的无效值，正确常量是vbOKOnly
• Form2里Match的查找参数写错了，传了个字符串"B"而不是实际的单元格区域，程序找不到查找范围直接转圈卡死
• 所有错误分支（匹配失败、文件只读、文件不存在）都没有做资源清理，已经打开的隐藏Excel实例、工作簿会一直留在后台占着文件锁，后续再打开文件必然提示占用
• Form2没有定义ws工作表对象就直接调用，会触发运行时错误
• 关闭工作簿、退出Excel的代码写在条件判断块内部，只要走错误分支直接Exit Sub就会跳过这些清理步骤，必然残留后台进程
• 文件存在性校验的代码被全注释了，要是数据库文件被删了，程序打开文件时直接报错崩溃

Form1 修复后完整代码 #

Private Sub CommandButton1_Click()
    ' 校验必填项是否填写完整
    If TextBox1.Value = "" Or TextBox2.Value = "" Or _
       TextBox3.Value = "" Or TextBox4.Value = "" Or TextBox5.Value = "" Then
        MsgBox "请填写所有必填项。"
        Exit Sub
    End If
        
    Call Submit_Data
    Call resetForm
    Unload Me
End Sub

Sub resetForm()
    TextBox1.Value = ""
    TextBox2.Value = ""
    TextBox3.Value = ""
    TextBox4.Value = ""
    TextBox5.Value = ""
    UserForm1.TextBox1.SetFocus
End Sub
        
Private Sub CommandButton2_Click()
    Unload Me
End Sub
        
Private Sub UserForm_Click()
        
End Sub
        
Sub Submit_Data()
    Application.ScreenUpdating = False
         
    Dim App As Excel.Application
    Dim wBook As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim FileName As String
    Dim iRow As Long, m As Variant, id As String
         
    FileName = ThisWorkbook.Path & "\test.xlsm"
         
    ' 校验文件是否存在
    If Dir(FileName) = "" Then
         MsgBox "数据库文件缺失，无法继续操作。", vbOKOnly + vbCritical, "错误"
         GoTo SafeExit
    End If
    
    ' 新建Excel实例，关闭系统弹窗避免卡住
    Set App = New Excel.Application
    App.Visible = False
    App.DisplayAlerts = False
         
    ' 打开文件时禁止弹出占用提示，若被占用则直接返回只读状态
    Set wBook = App.Workbooks.Open(FileName:=FileName, ReadOnly:=False, Notify:=False)
         
    If wBook.ReadOnly = True Then
         MsgBox "数据库正在被其他用户占用，请稍后再试。", vbOKOnly + vbCritical, "错误"
         GoTo SafeExit
    End If
         
    Set ws = wBook.Sheets("test")
    id = TextBox2.Value
    ' 跨实例调用函数必须绑定新建的App对象，不能用当前工程的Application
    m = App.Match(id, ws.Columns("B"), 0)
            
    If IsError(m) Then
        ' 未匹配到重复值，写入新行
        iRow = ws.Range("A" & App.Rows.Count).End(xlUp).Row + 1
        ws.Range("A" & iRow).Value = TextBox1.Value
        ws.Range("B" & iRow).Value = TextBox2.Value
        ws.Range("C" & iRow).Value = TextBox3.Value
        ws.Range("D" & iRow).Value = TextBox4.Value
        ws.Range("E" & iRow).Value = Date
        ws.Range("F" & iRow).Value = Time
        ws.Range("M" & iRow).Value = TextBox5.Value
    Else
        MsgBox "该工单已打卡，请勿重复提交！"
        GoTo SafeExit
    End If
       
    wBook.Close Savechanges:=True
    MsgBox "数据提交成功！"

SafeExit:
    ' 统一资源回收，避免残留后台进程锁死文件
    If Not wBook Is Nothing Then
        If wBook.ReadOnly = False Then wBook.Close Savechanges:=False
        Set wBook = Nothing
    End If
    If Not App Is Nothing Then
        App.Quit
        Set App = Nothing
    End If
    Call resetForm
    Application.ScreenUpdating = True
End Sub

Form2 修复后完整代码 #

Private Sub CommandButton1_Click()
    ' 校验必填项
    If TextBox1.Value = "" Then
       MsgBox "请输入工单号。"
       Exit Sub
    End If
        
    Call Submit_Data
    Call resetForm
    Unload Me
End Sub
        
Private Sub CommandButton2_Click()
    Unload Me
End Sub

Sub resetForm()
    TextBox1.Value = ""
    UserForm1.TextBox1.SetFocus
End Sub

Private Sub UserForm_Click()
End Sub
        
Sub Submit_Data()
    Application.ScreenUpdating = False
         
    Dim App As Excel.Application
    Dim wBook As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim FileName As String
    Dim m As Variant, id As String
         
    FileName = ThisWorkbook.Path & "\Database.xlsm"
         
    ' 校验文件存在
    If Dir(FileName) = "" Then
        MsgBox "数据库文件缺失，无法继续操作。", vbOKOnly + vbCritical, "错误"
        GoTo SafeExit
    End If
         
    ' 初始化Excel实例，禁用系统弹窗
    Set App = New Excel.Application
    App.Visible = False
    App.DisplayAlerts = False
         
    Set wBook = App.Workbooks.Open(FileName:=FileName, ReadOnly:=False, Notify:=False)
         
    If wBook.ReadOnly = True Then
        MsgBox "数据库正在被其他用户占用，请稍后再试。", vbOKOnly + vbCritical, "错误"
        GoTo SafeExit
    End If
         
    Set ws = wBook.Sheets("Database")
    id = TextBox1.Value
    ' 传入正确的B列查找区域，使用新实例的Match方法
    m = App.Match(id, ws.Columns("B"), 0)
            
    If IsError(m) Then
        MsgBox "该工单无进场记录，无法打卡出场"
        GoTo SafeExit
    End If
            
    ' 匹配成功，写入出场时间
    ws.Columns("F").Cells(m).Value = Time
    wBook.Close Savechanges:=True
    MsgBox "数据提交成功！"

SafeExit:
    ' 统一回收资源
    If Not wBook Is Nothing Then
        If wBook.ReadOnly = False Then wBook.Close Savechanges:=False
        Set wBook = Nothing
    End If
    If Not App Is Nothing Then
        App.Quit
        Set App = Nothing
    End If
    Call resetForm
    Application.ScreenUpdating = True
End Sub

关键修复说明 #

• 所有跨实例的Excel函数调用，全部绑定到新建的App对象上，解决跨进程调用导致的逻辑失效、无响应问题
• 打开文件前先禁用新实例的所有系统弹窗，打开文件时指定参数禁止弹出占用提示，直接通过ReadOnly属性判断占用状态，修正了常量拼写错误
• 新增统一的资源回收出口，无论程序走哪个分支退出，都会关闭打开的工作簿、退出新建的Excel进程，不会在后台残留进程锁死文件
• 修正Form2中Match函数的错误参数，传入正确的B列查找区域，补全缺失的ws工作表对象定义
• 启用文件存在性校验，避免文件缺失时触发运行错误
• 把工作簿关闭、实例退出的逻辑从条件分支内移到公共出口，避免分支退出时跳过资源释放

内容的提问来源于stack exchange，提问作者Jonathan Kaufman