ADODB 有时不记录数据

Question

我是 ADODB 的新手。我希望我的问题不是那么愚蠢。我打开一个从 Excel 表（用户界面）到另一个表（“数据库”）的 ADODB 连接。代码运行完美，但有时更新或插入的数据不会记录在数据库表中。我不知道为什么，也不知道如何检查它以避免它发生。我知道如果我打开数据库表，保存然后关闭，它会再次运行良好。有人知道原因吗？

代码的过程运行良好，Excel VBA调试器没有出现任何错误...然后我发布一些我认为可能存在问题的部分...

Public cn As ADODB.Connection
Public rst As ADODB.Recordset
Public sSQL As String

Public z, OP, Conf, TempoA, Setor As Double
Public FoundAp, FoundPar As Boolean

Private Sub txtCod_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Set cn = New ADODB.Connection
Set rst = New ADODB.Recordset

If Val(Application.Version) <= 11 Then 'Excel 2003 ou anterior
    cn.ConnectionString = _
      "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & EstaPasta_de_trabalho.DbPath & ";" & _
      "Extended Properties=Excel 8.0;"
Else 'Excel 2007 ou superior
    cn.ConnectionString = _
      "Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Data Source=" & EstaPasta_de_trabalho.DbPath & ";" & _
      "Extended Properties=Excel 12.0 Xml;"
End If
cn.Open

'Instrução Sql:
    sSQL = "SELECT * FROM [tb_Db_Ops$] " & _
        "WHERE Cod_Apont LIKE " & txtCod & ";"

    rst.CursorLocation = adUseServer
    rst.Open sSQL, cn, adOpenKeyset, adLockOptimistic, adCmdText

    If Not rst.EOF And Not rst.BOF Then
        OP = rst!OP
        frmApontamento.Visible = True
        txtApontA = txtCod.Text
        txtOpA = OP
        txtEtapa.Text = rst!Etapa
        txtDocA = rst!Documento
        txtObraA = Mid(rst!Obra, 12)
        Setor = CDbl(rst!Setor)
        If IsNull(rst!Status) = False Then
            Status = rst!Status
        End If
        If Status = "FINALIZADO" Then
            frmMsg.lblMsg.Caption = "OP já finalizada!"
            frmMsg.Show
            rst.Close
            cn.Close
            Set rst = Nothing
            Set cn = Nothing
            Exit Sub
        ElseIf Status = "EM EXECUÇÃO" Then
            FoundAp = True
            FoundPar = False
        ElseIf Status = "" Then
            FoundAp = False
            FoundPar = False
        Else
            FoundAp = True
            FoundPar = True
        End If
    Else
        frmMsg.lblMsg.Caption = "Apontamento NÃO encontrado na Base de Dados! Supervisão notificada! Tente novamente mais tarde!"
        frmMsg.Show
        Email.ErroBd = True
        Email.ErroGrav = False
        Email.Proced = "txtCod_Exit"
        Call Email_Erros
        rst.Close
        cn.Close
        Set rst = Nothing
        Set cn = Nothing
        Exit Sub
    End If

    rst.Close

sSQL = "UPDATE [tb_Apontamentos$] " & _
        "SET dt_f = NOW(), dt = NOW() - dt_i " & _
        "WHERE Cod_Apont LIKE " & txtApontR & " AND dt_f IS NULL;"

cn.Execute sSQL

Final:
If Not (rst Is Nothing) Then
    If rst.State = 1 Then
        rst.Close
    End If
    Set rst = Nothing
End If

If Not (cn Is Nothing) Then
    If cn.State = 1 Then
        cn.Close
    End If
    Set cn = Nothing
End If
end sub

它从用户表单文本框中获取一些值。它在 Windows 10 中的 2013 32 位 Excel 版本上运行。Microsoft ActiveX Data Objects 6.1 和 Microsoft ActiveX Data Objects Recordset 6.0 库已激活。接口是.xlsm，数据库是.xlsx

Answer 1

听起来您正在尝试从已关闭的工作簿中导入数据。我已经有一段时间没有尝试过了，但听起来宏记录器知道或者你正在记录的工作簿，所以本地工作簿，而不是外国工作簿，所以它丢失了对外国工作簿的引用.请参阅下面的代码示例。

 Import data from a closed workbook (ADO)

如果您想从已关闭的工作簿中导入大量数据，您可以使用 ADO 和下面的宏来执行此操作。如果要从关闭的工作簿中的第一个工作表之外的另一个工作表中检索数据，则必须引用用户定义的命名范围。下面的宏可以这样使用（在 Excel 2000 或更高版本中）：

GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "A1:B21", ActiveCell, False
GetDataFromClosedWorkbook "C:\FolderName\WorkbookName.xls", "MyDataRange", Range ("B3"), True

Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String, _
    TargetRange As Range, IncludeFieldNames As Boolean)
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
'   this will return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
'   this will return data from any worksheet in SourceFile
' SourceRange must include the range headers
'
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
Dim TargetCell As Range, i As Integer
    dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
        "ReadOnly=1;DBQ=" & SourceFile
    Set dbConnection = New ADODB.Connection
    On Error GoTo InvalidInput
    dbConnection.Open dbConnectionString ' open the database connection
    Set rs = dbConnection.Execute("[" & SourceRange & "]")
    Set TargetCell = TargetRange.Cells(1, 1)
    If IncludeFieldNames Then
        For i = 0 To rs.Fields.Count - 1
            TargetCell.Offset(0, i).Formula = rs.Fields(i).Name
        Next i
        Set TargetCell = TargetCell.Offset(1, 0)
    End If
    TargetCell.CopyFromRecordset rs
    rs.Close
    dbConnection.Close ' close the database connection
    Set TargetCell = Nothing
    Set rs = Nothing
    Set dbConnection = Nothing
    On Error GoTo 0
    Exit Sub
InvalidInput:
    MsgBox "The source file or source range is invalid!", _
        vbExclamation, "Get data from closed workbook"
End Sub

另一种不使用 CopyFromRecordSet 方法的方法

使用下面的宏，您可以执行导入并更好地控制从 RecordSet 返回的结果。

Sub TestReadDataFromWorkbook()
' fills data from a closed workbook in at the active cell
Dim tArray As Variant, r As Long, c As Long
    tArray = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
    ' without using the transpose function
    For r = LBound(tArray, 2) To UBound(tArray, 2)
        For c = LBound(tArray, 1) To UBound(tArray, 1)
            ActiveCell.Offset(r, c).Formula = tArray(c, r)
        Next c
    Next r
    ' using the transpose function (has limitations)
'    tArray = Application.WorksheetFunction.Transpose(tArray)
'    For r = LBound(tArray, 1) To UBound(tArray, 1)
'        For c = LBound(tArray, 2) To UBound(tArray, 2)
'            ActiveCell.Offset(r - 1, c - 1).Formula = tArray(r, c)
'        Next c
'    Next r
End Sub

Private Function ReadDataFromWorkbook(SourceFile As String, SourceRange As String) As Variant
' requires a reference to the Microsoft ActiveX Data Objects library
' if SourceRange is a range reference:
'   this function can only return data from the first worksheet in SourceFile
' if SourceRange is a defined name reference:
'   this function can return data from any worksheet in SourceFile
' SourceRange must include the range headers
' examples:
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:A21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "A1:B21")
' varRecordSetData = ReadDataFromWorkbook("C:\FolderName\SourceWbName.xls", "DefinedRangeName")
Dim dbConnection As ADODB.Connection, rs As ADODB.Recordset
Dim dbConnectionString As String
    dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & SourceFile
    Set dbConnection = New ADODB.Connection
    On Error GoTo InvalidInput
    dbConnection.Open dbConnectionString ' open the database connection
    Set rs = dbConnection.Execute("[" & SourceRange & "]")
    On Error GoTo 0
    ReadDataFromWorkbook = rs.GetRows ' returns a two dim array with all records in rs
    rs.Close
    dbConnection.Close ' close the database connection
    Set rs = Nothing
    Set dbConnection = Nothing
    On Error GoTo 0
    Exit Function
InvalidInput:
    MsgBox "The source file or source range is invalid!", vbExclamation, "Get data from closed workbook"
    Set rs = Nothing
    Set dbConnection = Nothing
End Function

请参阅下面的链接。

https://www.erlandsendata.no/english/index.php?d=envbadacimportwbado

也请查看此链接。

https://www.rondebruin.nl/win/s3/win024.htm