时间戳

首页 > 解决方案 > 如果第一次没有工作，使用错误处理程序让用户尝试再次提交表单

excel - 如果第一次没有工作，使用错误处理程序让用户尝试再次提交表单

问题描述

所以，我正在构建一个多人填写的用户表单。公共数据库文件将保存在 Sharepoint。只有在 2 个人没有同时按下提交按钮之前，该表单才能正常工作。

为了解决这个问题，我想到了一个错误处理程序，当第二个用户尝试同时提交表单时会显示一个错误处理程序，并且消息会说其他人正在使用该表单，请稍后再试。

这是我当前的提交代码：

Sub Submit()
    On Error GoTo eh
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AutomationSecurity = msoAutomationSecurityLow
    If frmForm.txtAE.Value = "" Or frmForm.txtAPL.Value = "" Or frmForm.txtBatches.Value = "" Or frmForm.txtProject.Value = "" Or frmForm.txtQA.Value = "" Or frmForm.txtTeam.Value = "" Or frmForm.cmbDS.Value = "" Or frmForm.cmbPriority.Value = "" Or frmForm.cmbRelease.Value = "" Then
        MsgBox ("Complete All fields marked with (*) to proceed")
    Else
        Dim strFileName As String
        Dim strFileExists As String
        'Call Downloadtest
        strFileName = ""
        strFileExists = Dir(strFileName)

        If strFileName <> "" Then
            MsgBox ("Another user is currently submitting a booking. Please wait for a minute, and then try again.")
        Else

            Dim nwb As Workbook
            Set nwb = Workbooks.Open("sharepoint link")

            nwb.Sheets("Sheet1").Unprotect Password:="password"
            Dim emptyRow As Long
            emptyRow = WorksheetFunction.CountA(nwb.Sheets("Sheet1").Range("A:A")) + 1

            Dim arDate As Variant
            arDate = Split(frmForm.dtPlanned.Value, "/")
            With nwb.Sheets("Sheet1")

                .Cells(emptyRow, 1) = emptyRow - 1
                .Cells(emptyRow, 2) = Date
                .Cells(emptyRow, 3) = frmForm.txtProject.Value
                .Cells(emptyRow, 4) = frmForm.txtTeam.Value
                .Cells(emptyRow, 5) = frmForm.txtAPL.Value
                .Cells(emptyRow, 6) = frmForm.txtQA.Value
                .Cells(emptyRow, 7) = frmForm.txtAE.Value
                .Cells(emptyRow, 8) = frmForm.cmbRelease.Value
                .Cells(emptyRow, 9) = frmForm.cmbDS.Value
                .Cells(emptyRow, 10) = frmForm.txtBatches.Value
                .Cells(emptyRow, 11) = frmForm.dtReview.Value
                .Cells(emptyRow, 12) = frmForm.dtSubmission.Value
                .Cells(emptyRow, 13) = frmForm.dtRelease.Value
                If frmForm.dtPlanned.Value = "" Then .Cells(emptyRow, 14) = "" Else .Cells(emptyRow, 14) = DateSerial(arDate(2), arDate(1), arDate(0))
                .Cells(emptyRow, 15) = frmForm.cmbPriority.Value
                .Cells(emptyRow, 16) = "Pending"
                .Cells(emptyRow, 17) = frmForm.txtRemarks.Value
                .Cells(emptyRow, 18) = Application.UserName

            End With
            nwb.Sheets("Sheet1").Protect Password:="password"
            'nwb.SaveAs ("sharepoint link")


            nwb.SaveAs Filename:="sharepoint link"
            nwb.Close
            'Kill ("C:\Users\username\Downloads\Planning Sheet\KF 6.0_checkout.xlsm")
            MsgBox ("Your Entry has been recorded.")
        End If
    End If
    Unload frmForm
eh:
    MsgBox("Someone else using the file")
End Sub

请忽略strFilename，strFileexists，我必须清理那部分。

问题在于，在我们单击“确定”错误后，表单会关闭。有什么方法可以在错误 MsgBox 上添加一个 Try again 按钮，用户可以按下该按钮，以便他们可以在几秒钟后再次尝试提交表单？而且它还应该防止关闭用户表单，因为如果发生错误，我不希望他们再次填写整个内容。

请帮忙，谢谢

标签： excelvbaerror-handling

解决方案

您可以尝试使用vbAbortRetryCancel或vbOKCancel参数调用 msgbox，在此处输入链接描述并以如下方式重组子：

Sub Submit()
     On Error ...
     iStat = vbRetry
     Do While iStat = vbRetry
        ...
         Unload frmForm
         iStat = vbOK 
     eh:
         iStat = MsgBox ("Someone...
     Loop

推荐阅读