您的位置: 首页  >  技术问答  >  使用ADODB/DAO，将数据从Excel上传到数据库（Access），检查数据是否存在正确的输入掩码

使用ADODB/DAO，将数据从Excel上传到数据库（Access），检查数据是否存在正确的输入掩码

分类: 技术问答 • 2022-02-17 16:15:05
问题描述：

我正在尝试编写一个VBA代码，它会使用ADODB连接将数据上传到Access数据库。问题是我想要在上传前检查数据完整性，因此检查输入掩码格式，允许的值，是否需要字段，字段长度，数据类型。到目前为止，我想通了，我会使用ADODB/DAO，将数据从Excel上传到数据库（Access），检查数据是否存在正确的输入掩码

  1. 让用户选择要上传的数据库，什么表（ADODB.OpenSchema）
  2. 连接使用DAO获取有关输入掩码等（至少输入掩码信息可以通过仅DAO完成）
  3. 连接到选定的表中，创建空的记录，断开（ADODB）
  4. 测试数据参数，同时建立批次记录，并用wrtong数据忽略线
  5. 上传数据

在上载到数据库之前，还有其他常用的方法来测试inputmask格式的数据吗？只要给我指示，我会谷歌休息

看看下面我到目前为止，如果你有兴趣。

谢谢

Option Explicit 
Option Base 1 

Sub opentest() 

Dim file As String, table As String 
Dim outputarray As Variant 
Dim cancelwork As Boolean 
Dim coll As Collection 
Set coll = New Collection 


Dim adSchemaTables As Long, adOpenDynamic As Long, adLockBatchOptimistic As Long, adUseClient As Long 'named methods/properties must be defined as numbers for late binding 
adOpenDynamic = 2 
adLockBatchOptimistic = 4 
adSchemaTables = 20 
adUseClient = 3 




With Application.FileDialog(msoFileDialogFilePicker) 'lets user select database 
    .Title = "Select Database" 
    .AllowMultiSelect = False 
    .Show 

    If .SelectedItems.Count = 0 Then 
      End 
     Else 
      file = CStr(.SelectedItems(1)) 
    End If 

End With 


Dim cnn As Object, rs As Object ' late binding, should allow no need for ADO library reference in excel 
Set cnn = createobject("ADODB.connection") 
Set rs = createobject("ADODB.Recordset") 

cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & file & ";" & "Persist Security Info=False" 

Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "link")) 'for linked tables 

Do While Not rs.EOF 
    coll.Add CStr(rs("table_name")) 
    rs.MoveNext 
Loop 

Set rs = Nothing 

Set rs = cnn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "table")) 'for actual tables 

Do While Not rs.EOF 
    coll.Add CStr(rs("table_name")) 
    rs.MoveNext 
Loop 

Call ListBox(coll, table) 'lets the user select table where to upload 

Set rs = Nothing 
Set rs = createobject("ADODB.Recordset") 
rs.CursorLocation = adUseClient 

rs.Open "select * from " & table & " where false", cnn, adOpenDynamic, adLockBatchOptimistic 'connection 

Set rs.ActiveConnection = Nothing 'disconnecting to build data 


Call dataload(rs, cancelwork) 'calling dataload function 

If cancelwork = True Then 
     Call closing(rs, cnn) 
     End 
End If 


Set rs.ActiveConnection = cnn 

rs.UpdateBatch 'uploading data 



Call closing(rs, cnn) 

End Sub 

Sub closing(rs As Object, cnn As Object) 


rs.Close 
Set rs = Nothing 
cnn.Close 
Set cnn = Nothing 

End Sub 

Private Sub ListBox(ByVal coll As Collection, ByRef table As String) 

Dim item As Variant 

For Each item In coll 
    ListBoxForm.ListBox1.AddItem (item) 
Next item 

ListBoxForm.Show 
table = ListBoxForm.ListBox1.value 

ListBoxForm.ListBox1.Clear 

End Sub 

Sub dataload(ByRef rs As Object, ByRef cancelwork As Boolean) 
Dim loadarray() As Variant 
Dim region As Range 
Dim response As VbMsgBoxResult 

On Error Resume Next 
Set region = Application.InputBox(Prompt:="Select data to upload", Type:=8) 
If region Is Nothing Then 
     End 
End If 

loadarray = region 

If (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) > rs.Fields.Count Then 
     MsgBox "Number of columns to be uploaded is greater then number of columns in database, ending" 
     cancelwork = True 
     Exit Sub 
    ElseIf (UBound(loadarray, 2) - LBound(loadarray, 1) + 1) < rs.Fields.Count Then 
     response = MsgBox("Number of columns to be uploaded is less then number of columns in database", vbOKCancel) 
     If response = vbCancel Then 
       cancelwork = True 
       Exit Sub 
     End If 
End If 

Set rs = recordsetload(rs, loadarray, region) 


End Sub 

Private Function recordsetload(rs As Object, loadarray As Variant, region As Range) As Object 

Dim rowi As Long, columni As Long, rsrow As Long 

For rowi = LBound(loadarray, 1) To UBound(loadarray, 1) 
     rs.AddNew 
     For columni = LBound(loadarray, 2) To UBound(loadarray, 2) 
       rs.Fields(columni - 1).value = loadarray(rowi, columni) 
     Next columni 
Next rowi 

Set recordsetload = rs 

End Function 

Sub daotry2() 
    Dim file As String 

    With Application.FileDialog(msoFileDialogFilePicker) 
     .Title = "Select Database" 
     .AllowMultiSelect = False 
     .Show 

     If .SelectedItems.Count = 0 Then 
       End 
      Else 
       file = CStr(.SelectedItems(1)) 
     End If 

    End With 

    Dim db As Object 'late binding without reference, seems to work, but might cause trouble, not tested 
    Dim tbl As Object 

    Dim dbe As Object 
    Set dbe = CreateObject("DAO.DBEngine.120") 'depends on win version 


    Set db = dbe.OpenDatabase(file) 
    Set tbl = db.TableDefs("CAPEX") 

    Debug.Print tbl.Fields(0).Properties("InputMask") 
    Debug.Print tbl.Fields(0).Properties("Size") 
    Debug.Print tbl.Fields(0).Properties("ValidationRule") 
    Debug.Print tbl.Fields(0).Properties("Required") 

    db.Close 

    End Sub

答

所以对我来说，它看起来像你正在做这个不必要的复杂。我不能说什么是最常见的模式，但是当我这样做时，我采用的方法是让代码无形地制作我想最终追加数据的表的副本，并尝试插入数据进入该临时表。然后，如果有任何错误，Access会自动创建一个名称为“ImportError”的表格，您可以通过该表格查找问题。您可以编写代码来计算每种错误的数量，并将该消息输出给用户。如果没有创建ImportError表，那么您知道没有错误，因此您可以将数据从临时表复制到最终表中，并删除临时表。

这种方法的好处是您不必让代码检查要附加到的表的输入掩码和验证规则;你只需就可以看看会发生什么。

答

使用威尔作业方法

通过创建和使用临时表，我不删除的问题，我有。如果我尝试从Excel导入数据到Access，并且有数据添加到不符合表规则的断开连接的记录集，批量更新仍然失败，只导入一些行。我不知道什么是导入和什么失败

我发现最简单的方法是“On error resume next”和更新每个添加的行上它自己的组合。如果它不遵循表的规则，则无法更新，并且我可以在Excel中将此行标记为红色。

轻微变化就adLockPesimistic（值2）的连接，并且没有记录

rs.Open "select * from " & table & " where false", cnn, adOpenDynamic, adLockPesimistic 'connection

而且recordsetload的断开被改变了。它只会添加遵循表规则的行。比较批量更新和单个记录更新，在661行上，23个字段的时间差很小（批量更新似乎在此数据量上一直慢1秒）

Private Function recordsetload(rs As Object, loadarray As Variant, region As Range) As Object 

Dim rowi As Long, columni As Long, rsrow As Long 

Err.Clear 
On Error Resume Next 
For rowi = LBound(loadarray, 1) To UBound(loadarray, 1) 
     If Err.Number = 0 Then 
       rs.AddNew 
      Else 
       Err.Clear 
     End If 
     For columni = LBound(loadarray, 2) To UBound(loadarray, 2) 
       rs.Fields(columni - 1).value = loadarray(rowi, columni) 
     Next columni 
     rs.Update 
     If Err.Number <> 0 Then 
       region.Rows(rowi).Interior.colorindex = 3 
     End If 

Next rowi 
On Error GoTo 0 

Set recordsetload = rs 

End Function

相关推荐