1

我在表单上有一个简单的命令按钮，“单击”事件过程用于将 Excel 文件逐行导入数据库，作为自定义过程的一部分。我已经设置了我的：

On Error GoTo DtUplErr

在程序开始时，还检查了 VBA 选项以确保“中断未处理的错误是我的选项”，但它根本不会移动到我的句柄书签，而是抛出标准运行时错误提示。

实际过程本身使用工作区来执行更新（不确定这是否会导致问题）

我遇到的错误是 3022（重复值），我确实打算查看并捕获它，因此这不是一个糟糕的数据问题。

我已经尝试将我所有的对象导入一个干净的 mdb 并且仍然没有运气，我真的很困惑。

有什么建议么？

完整代码（金额道歉）

Private Sub cmdSelect_Click()

'MS Excel
Dim xlApp       As Object 'Late Binding
Dim xlWrkBk     As Object
Dim xlWrkSt     As Object
Dim lngRow      As Long
Dim lngRowCnt   As Long

'Recordsets/Workspace
Dim WkSp        As DAO.Workspace 'Transaction Buffer
Dim rsMs        As DAO.Recordset 'Master
Dim rsSu        As DAO.Recordset 'Supplier
Dim rsAd        As DAO.Recordset 'Address
Dim rsAs        As DAO.Recordset 'Asset

'Misc
Dim strFile     As String
Dim dblMPRN     As Double
Dim lngPerc     As Long

On Error GoTo DtUplErr

Loading 1
strFile = DataUploadDialog
If strFile & "" = "" Then Exit Sub 'Quit if no file selected

'Open up the file
Set xlApp = CreateObject("Excel.Application")
Set xlWrkBk = xlApp.Workbooks.Open(strFile)
Set xlWrkSt = xlWrkBk.Worksheets(1)

Forms!frmUpload!cmdHidden.SetFocus
DoCmd.Hourglass -1

'Validate file format before import
With xlWrkSt
    If .Range("A1") <> "MPRN" _
    Or .Range("B1") <> "Notification" _
    Or .Range("C1") <> "Asset" _
    Or .Range("D1") <> "Reference No." _
    Or .Range("E1") <> "WMS Job No." _
    Or .Range("F1") <> "Meter Worker" _
    Or .Range("G1") <> "Job Status" _
    Or .Range("H1") <> "Date" _
    Or .Range("I1") <> "Time" _
    Or .Range("J1") <> "Sales district" _
    Or .Range("K1") <> "Customer" _
    Or .Range("L1") <> "Location" _
    Or .Range("M1") <> "Additional Info" _
    Or .Range("N1") <> "Street" _
    Or .Range("O1") <> "Dependent Locality" _
    Or .Range("P1") <> "Post Town" _
    Or .Range("Q1") <> "Postal Code" _
    Or .Range("R1") <> "Serial number" _
    Or .Range("S1") <> "Cur. Serial No." _
    Or .Range("T1") <> "Manufacturer Code" _
    Or .Range("U1") <> "Model Code" _
    Or .Range("V1") <> "Year of Manufacture" _
    Then
        xlWrkBk.Close
        xlApp.Quit
        Set xlApp = Nothing
        Set xlWrkBk = Nothing
        Set xlWrkSt = Nothing

        DoCmd.Hourglass 0

        MsgBox "Selected file is not in the correct format, please ensure " & _
               "the original column headers have not been moved/renamed" & _
               vbCr & vbCr & _
               "For further assistance please contact app support", 48
        Exit Sub
    End If
End With

Forms!frmUpload!cmdSelect.Enabled = 0
Forms!frmUpload!cmdClose.Enabled = 0

'Get total number of rows in file
lngRow = 1

Do Until xlWrkSt.Cells(lngRow, 1).Value & "" = ""
    lngRow = lngRow + 1
Loop

lngRowCnt = lngRow - 2

'Start writing to the tables
Set WkSp = DBEngine.Workspaces(0)

WkSp.BeginTrans

    Set rsMs = CurrentDb.OpenRecordset("tblMaster", dbOpenDynaset)
    Set rsSu = CurrentDb.OpenRecordset("tblSupplierHist", dbOpenDynaset)
    Set rsAd = CurrentDb.OpenRecordset("tblAddress", dbOpenDynaset)
    Set rsAs = CurrentDb.OpenRecordset("tblAssetHist", dbOpenDynaset)

    lngRow = 2

    Do Until lngRow > lngRowCnt + 1

ProcessUpload:
        With xlWrkSt

            dblMPRN = .Range("A" & lngRow) 'Store MPRN for additional tables

            'Master
            rsMs.AddNew
                rsMs!MPRN = dblMPRN
                rsMs!LoadTimestamp = Now()
                rsMs!Notification = .Range("B" & lngRow)
                rsMs!Asset = .Range("C" & lngRow)
                rsMs!JobRef = .Range("D" & lngRow)
                rsMs!WmsJobRef = .Range("E" & lngRow)
                rsMs!MeterWorker = .Range("F" & lngRow)
                rsMs!JobStatus = .Range("G" & lngRow)
                rsMs!JobTimestamp = .Range("H" & lngRow) & " " & .Range("I" & lngRow)
                rsMs!SalesDistrict = .Range("J" & lngRow)
                rsMs!AddInfo = .Range("M" & lngRow)
            rsMs.Update

            'Supplier
            rsSu.AddNew
                rsSu!MPRN = dblMPRN
                rsSu!SupplierID = .Range("K" & lngRow)
                rsSu!Timestamp = Now()
                rsSu!Advisor = "System"
            rsSu.Update

            'Address
            rsAd.AddNew
                rsAd!MPRN = dblMPRN
                rsAd!Street = .Range("N" & lngRow)
                rsAd!Locality = .Range("O" & lngRow)
                rsAd!Town = .Range("P" & lngRow)
                rsAd!PostCode = .Range("Q" & lngRow)
            rsAd.Update

            'Asset
            rsAs.AddNew
                rsAs!MPRN = dblMPRN
                rsAs!SN = .Range("R" & lngRow)
                rsAs!Make = .Range("T" & lngRow)
                rsAs!Model = .Range("U" & lngRow)
                rsAs!YOM = .Range("V" & lngRow)
                rsAs!Location = .Range("L" & lngRow)
                rsAs!Timestamp = Now()
                rsAs!Advisor = "System"
            rsAs.Update

            'Work out progress
            lngPerc = Round((lngRow / lngRowCnt) * 100)
            lngPerc = IIf(lngPerc > 0, lngPerc - 1, lngPerc)

            Forms!frmUpload!txtPerc = lngPerc & "/" & lngRowCnt & "  (" & lngPerc & " %)"
            Forms!frmUpload!ProgBar.Value = lngPerc

            'Let the display catch up
            DoEvents
            Sleep 100

            lngRow = lngRow + 1 'Advance

        End With

    Loop

WkSp.CommitTrans

Forms!frmUpload!txtPerc = lngRowCnt & "/" & lngRowCnt & "  (100 %)"
Forms!frmUpload!ProgBar.Value = 100
DoEvents

'Cleanup
xlWrkBk.Close
xlApp.Quit
Set xlApp = Nothing
Set xlWrkBk = Nothing
Set xlWrkSt = Nothing

rsMs.Close
rsSu.Close
rsAd.Close
rsAs.Close
WkSp.Close
Set rsMs = Nothing
Set rsSu = Nothing
Set rsAd = Nothing
Set rsAs = Nothing
Set WkSp = Nothing

Forms!frmUpload!cmdClose.Enabled = -1

DoCmd.Hourglass 0

Exit Sub

DtUplErr:
Select Case Err

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        GoTo ProcessUpload

    Case Else 'Cleanup and then show error
        WkSp.Rollback 'Cancel transaction so data not affected

        xlWrkBk.Close
        xlApp.Quit
        Set xlApp = Nothing
        Set xlWrkBk = Nothing
        Set xlWrkSt = Nothing

        rsMs.Close
        rsSu.Close
        rsAd.Close
        rsAs.Close
        WkSp.Close
        Set rsMs = Nothing
        Set rsSu = Nothing
        Set rsAd = Nothing
        Set rsAs = Nothing
        Set WkSp = Nothing

        Forms!frmUpload!cmdSelect.Enabled = -1
        Forms!frmUpload!cmdClose.Enabled = -1

        DoCmd.Hourglass 0

        ShowError Err, "ModFunctions", "DataUpload", Err.Description

End Select

End Sub
4

3 回答 3

1

感谢@HansUp 的建议，我逐步检查了我的代码，试图阻止错误的根源，正如我所期望的那样，这是最简单（但最令人讨厌）的事情。

在第一个错误上，我的代码将按预期运行到这一点：

DtUplErr:
    Select Case Err

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        GoTo ProcessUpload

然后回到下一个项目和过程的其余部分，但是在下一个错误时它会失败，并且有效地归结为一个“单词”，我已经改变了这一行：

Goto ProcessUpload

到：

Resume ProcessUpload

现在继续处理错误，唷，我一直知道“Resume”关键字超过“GoTo”是有充分理由的，但直到现在还没有感受到错误的痛苦^_^

于 2012-07-26T14:54:47.180 回答
1

为了简化您的代码以使将来的故障排除更容易，我提出了这个建议。

将部分从更改'Cleanup为Exit Sub：

MySubShallHaveOnlyOneExitPoint:
    xlWrkBk.Close
    xlApp.Quit
    Set xlApp = Nothing
    Set xlWrkBk = Nothing
    Set xlWrkSt = Nothing
    rsMs.Close
    rsSu.Close
    rsAd.Close
    rsAs.Close
    WkSp.Close
    Set rsMs = Nothing
    Set rsSu = Nothing
    Set rsAd = Nothing
    Set rsAs = Nothing
    Set WkSp = Nothing
    Forms!frmUpload!cmdClose.Enabled = -1
    DoCmd.Hourglass 0
    Exit Sub

然后Case Else你的错误处理程序中的可以简化为：

Case Else ' Cleanup and then show error '
    WkSp.Rollback ' Cancel transaction so data not affected '
    Forms!frmUpload!cmdSelect.Enabled = -1
    ShowError Err, "ModFunctions", "DataUpload", Err.Description
    Resume MySubShallHaveOnlyOneExitPoint
于 2012-07-26T16:15:48.867 回答
0

编辑：Err 对象默认返回的“数字”属性。

我认为问题在于你的Select Case陈述。您缺少 err 对象的“数字”属性。所以它只是跳过整个Select Case块

DtUplErr:
Select Case Err.Number 'Use the Error Number for your Select Case Statement

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        Err.Clear
        On Error Goto DtUplErr 'might need to tell it to branch on error again, i havn't tested
        GoTo ProcessUpload

    Case Else 'Cleanup and then show error
        MsgBox Err.Description
        'do whatever here
End Select

于 2012-07-26T14:13:54.353 回答