VBA学习(64)： Excel表格数据导入Access数据库初探

1.Excel导入Access核心代码

数据导入核心代码，CmdImport_Click()，代码可能有一些无效语句，没有来得及整理，大家将就着看吧，关键是思路。

Private Sub CmdImport_Click()
    ThisWorkbook.Activate
    If Not wContinue("即将导入！" & Chr(10) _
                   & "勾选【追加】则保留原有数据" & Chr(10) _
                   & " 不勾【追加】则删除原有数据！" _
                   & Chr(10) & " 请谨慎操作！") Then Exit Sub
    
    'On Error Resume Next
    Dim arrT(), arr()
    Dim iPath As String
    Dim iSheet As Worksheet
    Dim CurrTable As String
    Dim tbTitle()
    
    
    Dim cnn As Object                            '数据库连接
    Dim rs As Object
    Dim StrCnn As String                         'ACCESS连接语句
    Dim mydata As String                         '数据库的完整路径和名称
    Dim aData()
    Dim FieldsNum As Integer
    
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Psw = clsGT.GetPsW
    StrCnn = clsGT.GetStrCnn(DataFile, Psw)
    
    cnn.Open StrCnn                              '打开数据库链接
    
    If Me.CkB_Add.Value = True Then
        
        For Each LvItem In Me.LvSelected.ListItems
            CurrTable = LvItem.Text
            SQL1 = " select * from [Excel 12.0;DataBase=" & sFile & "].[" & CurrTable & "$]"
            arrT = clsDQ.GetData(SQL1)
            rs.Open CurrTable, cnn, 1, 3
            For i = 0 To UBound(arrT, 2)
                If arrT(1, i) = "" Then Exit For
                rs.AddNew
                For j = 1 To UBound(arrT, 1)
                    rs.Fields(j) = arrT(j, i)
                Next
                rs.Update
            Next
        Next
    Else
        If Not wContinue("即将删除原有数据，添加新数据！") Then Exit Sub
        
        For Each LvItem In Me.LvSelected.ListItems
            CurrTable = LvItem.Text
            
            sql = "delete * from " & CurrTable
            clsDQ.ExecuteSQL (sql)
            sql = "ALTER TABLE " & CurrTable & " ALTER COLUMN ID COUNTER(1,1)"   '重置ID计数器
            clsDQ.ExecuteSQL (sql)
            SQL1 = " select * from [Excel 12.0;DataBase=" & sFile & "].[" & CurrTable & "$]"
            arrT = clsDQ.GetData(SQL1)
            tbTitle = clsDQ.GetFields(SQL1)
            rs.Open CurrTable, cnn, 1, 3
            For i = 0 To UBound(arrT, 2)
                If arrT(1, i) = "" Then Exit For
                rs.AddNew
                For j = 1 To UBound(arrT, 1)
                    rs.Fields(tbTitle(j)) = arrT(j, i)
                Next
                rs.Update
            Next
            rs.Close
        Next
    End If
    Application.DisplayAlerts = False
    MsgBox ("导入成功！")
    
    '关闭打开的导入源文件（打开后是隐藏的，没有关闭它会造成一些问题
    '从完整径中截取文件名
    sFile = Mid(sFile, InStrRev(sFile, "\") + 1, Len(sFile) - InStrRev(sFile, "\"))
    Workbooks(sFile).Close SaveChanges:=False
    Application.DisplayAlerts = True
    
    cnn.Close
    Set cnn = Nothing
    Set rs = Nothing
    Unload Me
End Sub

2.数据校验初探

1、导入的Excel表的字段与Access表的字段是否一致（包括排列顺序）？

2、比如，在导入“会计凭证”的时候，检查Excel表中的会计科目是否已存在于Access数据库表？

今天花了点时间，初步实现异常数据校验功能，把过程写出来分享给大家，这是校验的结果，它列出了“不存在的字段“、”位置不同的字段“以及“不存在的数据记录”：

我们来看一下操作演示：

先说明一下背景：

1、图中的“甲有限公司（数据备份)20230423....“文件是我从这个财务管理系统中导出来的，字段名称及顺序是完全一致的。

2、然后，我把两个表中的字段名称改了一下，把【tb凭证】表中的科目代码改了两个、字段位置调换一些。

结果就如图所示，数据检验有异常，如果不做修改，应该是显示校验成功，不防再测试一下，我先导出，不做任何修改，立即做导入数据校验：

我们看一下代码（数据校验按钮）：

Private Sub CmdValidation_Click()
   Dim xlcnn As Object   '数据库连接，连接excel
    Dim xlrs As Object   '记录集对象
    Dim xlStrCnn As String     'Excel SQL 查询连接语句
    Dim xlData()    '数组，存放记录
    Dim xlTitle()   '数组，存放excel表头
    Dim acTitle()   '数组，存放Access表头
    Dim Msg As String, strCheck As String   '存放校验结果信息
    Dim arr()    '数组，存放从access中查询的校验数据
    On Error Resume Next
    Set xlcnn = CreateObject("ADODB.Connection")
    Set xlrs = CreateObject("ADODB.Recordset")
    xlStrCnn = clsGT.GetStrCnn(sFile)   '自定义函数，生成查询连接字符串
    xlcnn.Open xlStrCnn    '打开连接
    For Each LvItem In Me.LvSelected.ListItems  '循环选择的每一个表
        CurrTable = LvItem.Text
        SQL1 = " select * from  [" & CurrTable & "$]"
        Set xlrs = xlcnn.Execute(SQL1)
        xlData = xlrs.getrows
        n = xlrs.Fields.Count - 1
        ReDim xlTitle(n)
        For i = 0 To n
            xlTitle(i) = xlrs.Fields(i).Name
        Next
        sql = "select * from " & CurrTable
        acTitle = clsDQ.GetFields(sql)
        If UBound(acTitle) <> n Then
            Msg = Msg & "【" & CurrTable & "】字段数量不一致" & Chr(10)
        Else
          strCheck = Join(acTitle, "/")
            strCheck = "/" & strCheck & "/"
            For i = 0 To n
                If InStr(strCheck, xlTitle(i)) = 0 Then
                    Msg = Msg & "【" & CurrTable & "】【" & xlTitle(i) & "】字段不存在" & Chr(10)
                Else
                    If xlTitle(i) <> acTitle(i) Then
                        Msg = Msg & "【" & CurrTable & "】【" & xlTitle(i) & "<--> " & acTitle(i) & "】字段位置不同" & Chr(10)
                        'Stop
                    End If
                End If
            Next
        End If
        If CurrTable = "tb凭证" Then
            Dim PosAccCode As Integer
            arr = clsDQ.GetData("select 科目代码 from tb科目")
            strCheck = Join(FlattenArray(arr), "/")
            strCheck = "/" & strCheck & "/"
            PosAccCode = Pxy(xlTitle, "科目代码") - 1
            For k = 0 To UBound(xlData, 2)
                If InStr(strCheck, xlData(PosAccCode, k)) = 0 Then
                    Msg = Msg & "【" & CurrTable & "】【" & xlData(PosAccCode, k) & "】科目代码不存在" & Chr(10)
                End If
            Next
        End If
    Next
    If Msg = "" Then
        MsgBox "字段校验无误！"
    Else
        MsgBox Msg
    End If
End Sub

简单解释一下代码：

1、定义变量

2、从用户窗体右边的listivew循环读取要校验的表名

3、把列表中的Excel表的字段名存入数组xlTitle

4、循环xlTitle，查询Access数据库中同名的表，字段存入acTitle 

5、比较xlTitle与acTitle字段的数据、名称、位置，如果有不相同的记录，把它记入Msg

6、字段比较完了，再比较相关记录，这里我们暂时就搞了一个【tb凭证】表中，科目代码是否在Access数据库的【tb科目】中存在。

7、结束比较，如果没有异常，则Msg为空，我们输出提示信息“字段校验无误“，否则，则输出Msg的内容，我们可以看到是哪里出了问题。

技术交流，软件开发，欢迎微信沟通：