使用ADODB / DAO将数据从Excel上传到数据库(访问)，检查数据是否正确输入掩码

Question

我正在尝试编写一个VBA代码，该代码将使用ADODB连接上传到访问数据库。问题在于我想在上传之前检查数据完整性，因此请检查输入掩码格式，允许值，是否需要字段，字段长度，数据类型。到目前为止，我想出的是

1. 让用户选择哪个数据库以及哪个表上传到（adodb.openschema）
2. 与DAO连接以获取有关InputMask和其他的信息（至少只能由DAO完成）
3. 连接到选定的表，创建空记录集，断开连接（ADODB）
4. 在构建批处理集时，测试数据到参数，而使用WRTONG数据忽略行
5. 上传数据

在上传到数据库之前，是否还有其他常用的方法来测试输入格式的数据？只要给我指示，我将Google Rest

如果您有兴趣，请参阅下面我到目前为止的内容。

谢谢

 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

Answer 1

所以对我来说，看起来您使这是不必要的复杂。我无法谈论最常见的模式，但是当我这样做时，我采用的方法是让代码不可见地副本，我想最终将数据附加到，并尝试插入数据进入那个登台表。然后，如果有任何错误，访问会自动在名称中使用" Importerror"的表格，您可以查看这些表以识别问题。您可以编写代码来计算每种错误的数量，并向用户输出该消息。如果未创建该InverterRor表，则您知道没有错误，因此您可以将登台表中的数据复制到最后一个表中，并删除登台表。

这种方法的好处是，您不必将代码检查您要附加到的表的输入掩码和验证规则；您只是做，看看会发生什么。

Answer 2

使用威尔·作业方法

通过创建和使用登台表，我不会删除我遇到的问题。如果我尝试从Excel导入数据以访问，并且在断开的记录集中添加了不符合表规则的数据，则通过批处理更新仍然失败，并且仅导入一些行。我不知道是什么进口和失败的

我发现的最简单方法是"下一步错误简历"的组合，并自行更新每条线。如果它不遵循表规则，它将无法更新，我可以在Excel中标记此行红色。

在adlockpesimistic上的连接略有变化（值2），并且没有删除记录集

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

和 recordsetload已更改。它将仅添加遵循表规则的行。比较批处理更新和单一记录更新，在661行23字段上的时间差异很小（批处理更新似乎始终在此数量的数据上慢1s）

）

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