Microsoft VBA Excel Access 核对数据

问题描述

简述：
有2份文件，分别是Summary.xlsm和Output.MDB。需要在Summary.xlsm写个VBA。内容是：
提取全部Summary.xlsm中sheet的名称，如果sheet的名称，在Output.MDB中找到资料表的名称是字符串"Fruit - "加上对应sheet名称，它们两个内容是不一样的，则输出弹窗（所有sheet的名称），如果一致则输出弹窗（“Well Done!”）。

---

代码描述

1. 循环遍历 Summary.xlsm 中的所有工作表。
2. 对于每个工作表，构造 Output.MDB 中的表名（即 "Fruit - " 加上工作表名称）。
3. 打开 Output.MDB 数据库，检查表是否存在，并对其进行比较。比较内容是sheet中第三行开始，A-G列的全部有值单元格和Access中的资料表对应单元格。
4. 如果存在任何不一致，记录下来并最后显示一个包含所有不一致名称的弹窗。
5. 如果全部一致，则显示弹窗，显示 "Well Done!"。

Sub CompareSheetsWithDatabaseTables()
    Dim ws As Worksheet
    Dim sheetName As String
    Dim tableName As String
    Dim conn As Object
    Dim rst As Object
    Dim sql As String
    Dim col As Integer
    Dim row As Integer
    Dim excelValue As String
    Dim dbValue As String
    Dim isWellDone As Boolean
    Dim dbName As String
    Dim mismatchList As String

    dbName = ThisWorkbook.Path & "\Output.MDB" ' 指定数据库文件路径
    mismatchList = ""
    isWellDone = True

    ' 设置数据库连接字符串
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbName
    
    For Each ws In ThisWorkbook.Sheets
        sheetName = ws.Name
        tableName = "Fruit - " & sheetName
        
        ' 检查表是否存在
        sql = "SELECT TOP 1 * FROM [" & tableName & "]"
        Set rst = CreateObject("ADODB.Recordset")

        On Error Resume Next
        rst.Open sql, conn, 1, 1 ' 1, 1 = adOpenKeyset, adLockReadOnly
        If Err.Number <> 0 Then
            ' 表不存在或无法打开
            isWellDone = False
            mismatchList = mismatchList & tableName & " (Table not found or cannot open)" & vbNewLine
            Err.Clear
        Else
            On Error GoTo 0
            ' 逐行逐列进行比较
            For row = 3 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                For col = 1 To 7 ' A到G列
                    excelValue = ws.Cells(row, col).Value
                    dbValue = rst.Fields(col - 1).Value ' 记录集字段索引从 0 开始
                    
                    ' 如果 Excel 单元格有值，则比较
                    If Not IsEmpty(excelValue) Then
                        If excelValue <> dbValue Then
                            ' 内容不一致
                            isWellDone = False
                            mismatchList = mismatchList & tableName & " (Mismatch in Cell " & ws.Cells(row, col).Address & ")" & vbNewLine
                            Exit For ' 跳出循环，继续检查下一张表
                        End If
                    End If
                Next col
                If Not isWellDone Then Exit For ' 如果已经有不一致，跳出行循环
                rst.MoveNext ' 移动到下一条记录
                If rst.EOF Then Exit For ' 如果记录集结束，跳出行循环
            Next row
        End If
        rst.Close
    Next ws
    
    conn.Close
    
    ' 展示结果
    If isWellDone Then
        MsgBox "Well Done!", vbInformation
    Else
        MsgBox "The following mismatches were found:" & vbNewLine & mismatchList, vbCritical
    End If
End Sub

注意

• 需要引用适当的 ActiveX 数据对象库。在 VBA 编辑器中，通过 “工具” -> “引用…”，然后选择 “Microsoft ActiveX Data Objects X.X Library”。
• 在比较之前，上面的代码假定 Excel 工作表和 Access 表中的行数是一致的。如果行数不一致，需要添加额外的逻辑来处理这种情况。
• 在实际应用中，如果数据库较大或者表很多，上述代码可能运行较慢。
• 错误处理在这个脚本中很基本，仅用于继续执行循环。根据实际需要，可能要添加更复杂的错误处理机制。
• 确保将 dbName 设置为正确的 Output.MDB 文件路径。
• 由于 Access SQL 查询不区分大小写，而 VBA 比较默认是区分大小写的，这可能会影响比较结果。如果需要，可以使用 StrComp 函数来进行不区分大小写的比较。