访问 VBA。检测记录集条目是否会溢出

Question

我有以下代码循环通过查询生成的记录集，有时，查询中的几行将返回 (0/0)。当循环通过记录集写出到 excel 时，如果查询中的行确实返回 (0/0)，我在尝试访问它时收到溢出错误。我试图捕捉这个溢出错误，并将字符串“0%”分配给我的变量，而不是溢出值。有谁知道一种方法来捕捉和解决这些溢出错误？

Set qdf = CurrentDb.CreateQueryDef("Latest Estimate", sSQL)

            Set dbs = CurrentDb
            Set rstAnswer = dbs.OpenRecordset("Latest Estimate")

            If Not (rstAnswer.EOF And rstAnswer.BOF) Then
                rstAnswer.MoveFirst
                Do Until rstAnswer.EOF
                    tempString = CStr(rstAnswer!BU)
                    xlSheet.Range("BA" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer!Program)
                    xlSheet.Range("BB" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![EIS Date])
                    xlSheet.Range("BC" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![Part Count])
                    xlSheet.Range("BD" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![Current Actual Cost Index])
                    xlSheet.Range("BE" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![LTA Index ($)])
                    xlSheet.Range("BF" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![LTA Index (part count)])
                    xlSheet.Range("BG" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![LCB Index])
                    xlSheet.Range("BH" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![Drawings Released by Need Date])
                    xlSheet.Range("BI" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![Total Drawings released vs Needed])
                    xlSheet.Range("BJ" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![% Of Parts With Suppliers Selected])
                    xlSheet.Range("BK" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![% POs placed vs needed])
                    xlSheet.Range("BL" & CStr(tempRow)).Value = tempString
                    'tempString = CStr(rstAnswer![UPPAP Requirement])
                    xlSheet.Range("BM" & CStr(tempRow)).Value = tempString
                    tempString = CStr(rstAnswer![Number of parts identified for UPPAP])
                    xlSheet.Range("BN" & CStr(tempRow)).Value = tempString
                    rstAnswer.MoveNext
                    tempRow = tempRow + 1
                Loop

            Else
                MsgBox "There are no records in this recordset"
            End If
            programsAnswer.MoveNext
        Loop

我尝试使用 GoTo 捕获溢出错误并将新值分配给我的 tempString 变量，但这不起作用，即使它起作用了，我实现它的方式也会很麻烦。

Answer 1

如果您不知道在范围对象上使用 CopyFromRecordset 方法，请检查一下。如果您的记录集只包含您想转储到 excel 中的列，您可以大大简化您的代码。

eg xlSheet.Range("BA"&1).CopyFromRecordset  rstAnswer 

这里有一些使用 ADO 记录集的示例代码，但 DAO 也可以工作！

'
'Example of gathering data from an Access Application
' into excel (but similar for other apps)
'
Private Sub cmdGather_Click()

    'Define Variables
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
    Dim oAdoConnect As Object
    Dim adoRecordset As ADODB.Recordset
    Dim lngColumn  As Long
    Dim strNewFile As String
    Dim strFilePath As String
    Dim strSQL As String

    'Always have a way to handle errors
    On Error GoTo Handler

    'Establish your ADO connection
    Set oAdoConnect = CreateObject("ADODB.Connection")
    oAdoConnect.Provider = "Microsoft.ACE.OLEDB.12.0"
    oAdoConnect.Open = Application.ActiveWorkbook.Path & "\Inventory.mdb"

    'Create the SQL statement
    strSQL = _
        "SELECT Customers.* " & _
        "FROM Customers " & _
        "WHERE (((Customers.ContactName) Like ""M*""));"

    'Create and open your recordset
    Set adoRecordset = CreateObject("ADODB.Recordset")
    adoRecordset.Open strSQL, oAdoConnect, adOpenStatic, adLockReadOnly

    'Create your Excel spreadsheet
    Set xlApp = Application
    Set xlWorkbook = xlApp.Workbooks.Add

    'Add the new Worksheet
    With xlWorkbook

        Set xlSheet = .Worksheets.Add
        xlSheet.Name = "Customers"

        ' Adds field names as column headers
        For lngColumn = 0 To adoRecordset.Fields.Count - 1
            xlSheet.Cells(1, lngColumn + 1).Value = adoRecordset.Fields(lngColumn).Name
        Next

        ' bold headers
        xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, adoRecordset.Fields.Count)).Font.Bold = True

        ' dump the data from the query
        xlSheet.Range("A2").CopyFromRecordset adoRecordset

    End With

    'Close the RecordSet
    adoRecordset.Close

    'Cleanup variables
    Set adoRecordset = Nothing
    Set oAdoConnect = Nothing
    Set xlSheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    Exit Sub

Handler:
    MsgBox _
        "An Error Occurred!" & vbNewLine & vbNewLine & _
        "Error Number: " & Err.Number & vbNewLine & vbNewLine & _
        "Error Message: " & vbNewLine & Err.Description & vbNewLine & vbNewLine & _
        "Error Source: " & Err.Source, vbOKOnly, "Error"
    Exit Sub
End Sub

Answer 2

在投射之前检查值。

If rstAnswer.Fields("Drawings Released by Need Date").Value <> "0/0" Then
    tempString = CStr(rstAnswer!Drawings Released by Need Date)
Else
    tempString = "0%"
End If