Microsoft VBA Excel 操控 Access资料表和查询代码进行搬运操作

偷心伊普西隆

已于 2024-06-28 14:59:20 修改

阅读量431

点赞数 3

分类专栏： VBA学习和实践文章标签： microsoft excel 前端

于 2024-06-27 15:50:18 首次发布

本文链接：https://blog.csdn.net/RandPython/article/details/139793838

版权

VBA学习和实践专栏收录该内容

17 篇文章 0 订阅

订阅专栏

问题场景

Run_No	Source_Address	Source_File	Destination_Address	Destination_File	Copy_Indicator
1	C:\Users\EP\path\to\File	SSS-1.MDB	C:\Users\EP\path\to\File	SSC-1.MDB	Y
2	C:\Users\EP\path\to\File	SSS-2.MDB	C:\Users\EP\path\to\File	SSC-2.MDB	Y
3	C:\Users\EP\path\to\File	SSS-3.MDB	C:\Users\EP\path\to\File	SSC-3.MDB	N
4	C:\Users\EP\path\to\File	SSS-4.MDB	C:\Users\EP\path\to\File	SSC-4.MDB	N
5	C:\Users\EP\path\to\File	SSS-5.MDB	C:\Users\EP\path\to\File	SSC-5.MDB	N
6	C:\Users\EP\path\to\File	SSS-6.MDB	C:\Users\EP\path\to\File	SSC-6.MDB	Y

注意：表格的标题不仅仅是该单元格的值，更是将该单元格命名为对应的名称，例如 “Run_No” 所在单元格的名称是 “Run_No” 、"Copy_Indicator " 所在单元格的名称是 "Copy_Indicator " 。

执行逻辑：试图构建主函数 Sub 和两个子函数 Function，实现以下功能：

主函数 Sub ：
- 将需要复制的资料表和查询的名称分别储存成数组；
- 循环 “Run_No” ，每次循环都需要根据 “Copy_Indicator” 判断是否需要继续执行剩余代码，如果是"Y"就执行，否则就跳过；
  - 根据前一步是 “Y”，组合来源文件和目标文件，即将本次循环中同一行的 “Source_Address” 和 “Source_File” 组合以及 “Destination_Address” 和 “Destination_File” 组合，并打开这两文件；
  - for循环资料表和查询的名称组成的数组，每次调用两个子函数 Function，将需要的资料表和查询通过这两个子函数从来源文件完整复制到目标文件。
子函数 Function
- 资料表子函数
  - 输入资料表名称、来源文件和目标文件，实现资料表的完美复制（包括数据结构和SQL）。
- 查询子函数
  - 输入查询名称、来源文件和目标文件，实现查询的完美复制。

代码描述

主函数 Sub CopyDatabaseObjects ：
- 遍历每一行，检查 “Copy_Indicator” 是否为 “Y”，如果是，则组合文件路径，并打开数据库文件进行复制操作。
子函数 CopyTable 和 CopyQuery：
- 函数接收资料表和查询的名称，然后从源数据库复制到目标数据库。

总结

中文

Sub CopyDatabaseObjects()
    ' 定义数组存储资料表和查询的名称
    Dim tables() As String
    Dim queries() As String
    
    ' 示例数据，需要根据实际情况填充
    tables = Array("Table1", "Table2")
    queries = Array("Query1", "Query2")
    
    Dim i As Integer
    Dim sourcePath As String
    Dim destinationPath As String
    
    ' 循环处理每一行
    For i = 1 To 6 ' 假设有6次运行，应根据实际行数进行修改（或者根据之前的文章修改，有很多循环方法）
        ' 检查是否需要复制
        If Cells(i + 1, 6).Value = "Y" Then
            ' 组合文件路径
            sourcePath = Cells(i + 1, 2).Value & "\" & Cells(i + 1, 3).Value
            destinationPath = Cells(i + 1, 4).Value & "\" & Cells(i + 1, 5).Value
            
            ' 打开源文件和目标文件
            Dim srcDB As Object, destDB As Object
            Set srcDB = OpenDatabase(sourcePath)
            Set destDB = OpenDatabase(destinationPath)
            
            ' 复制资料表
            Dim j As Integer
            For j = LBound(tables) To UBound(tables)
                Call CopyTable(tables(j), srcDB, destDB)
            Next j
            
            ' 复制查询
            For j = LBound(queries) To UBound(queries)
                Call CopyQuery(queries(j), srcDB, destDB)
            Next j
            
            ' 关闭数据库
            srcDB.Close
            destDB.Close
        End If
    Next i
End Sub

Function CopyTable(tableName As String, srcDB As Object, destDB As Object)
    ' 复制资料表
    srcDB.TableDefs(tableName).CopyStructureAndData destDB, tableName
End Function

Function CopyQuery(queryName As String, srcDB As Object, destDB As Object)
    ' 复制查询
    destDB.CreateQueryDef(queryName, srcDB.QueryDefs(queryName).SQL)
End Function

英文

Sub CopyDatabaseObjects()
    ' Define the names of the array storage tables and queries
    Dim tables() As String
    Dim queries() As String
    
    tables = Array("Table1", "Table2")
    queries = Array("Query1", "Query2")
    
    Dim i As Integer
    Dim sourcePath As String
    Dim destinationPath As String
    
    ' Loop through each row
    For i = 1 To 6 
        ' Check whether replication is required
        If Cells(i + 1, 6).Value = "Y" Then
            ' Combined file path
            sourcePath = Cells(i + 1, 2).Value & "\" & Cells(i + 1, 3).Value
            destinationPath = Cells(i + 1, 4).Value & "\" & Cells(i + 1, 5).Value
            ' Open
            Dim srcDB As Object, destDB As Object
            Set srcDB = OpenDatabase(sourcePath)
            Set destDB = OpenDatabase(destinationPath)
            
            ' Copy Table
            Dim j As Integer
            For j = LBound(tables) To UBound(tables)
                Call CopyTable(tables(j), srcDB, destDB)
            Next j
            
            ' Copy Query
            For j = LBound(queries) To UBound(queries)
                Call CopyQuery(queries(j), srcDB, destDB)
            Next j
            
            ' Close
            srcDB.Close
            destDB.Close
        End If
    Next i
End Sub

Function CopyTable(tableName As String, srcDB As Object, destDB As Object)
    srcDB.TableDefs(tableName).CopyStructureAndData destDB, tableName
End Function

Function CopyQuery(queryName As String, srcDB As Object, destDB As Object)
    destDB.CreateQueryDef(queryName, srcDB.QueryDefs(queryName).SQL)
End Function

反馈一

如果遇到 DAO DLL 加载错误或者无法正常使用 DAO，使用 ActiveX Data Objects (ADO) 来操作 Access 数据库。ADO 是一个更通用的数据访问技术，它支持多种类型的数据库，包括 SQL Server 和 Access。

打开 VBA 编辑器。
点击 “工具” -> “引用…”
在弹出的“引用”对话框中，勾选 “Microsoft ActiveX Data Objects x.x Library”

Sub CopyDatabaseObjectsUsingADO()
    Dim tables() As Variant 
    Dim queries() As Variant 
    tables = Array("Table1", "Table2")
    queries = Array("Query1", "Query2")

    Dim i As Integer
    Dim sourcePath As String
    Dim destinationPath As String

    ' 创建 ADO 连接和记录集对象
    Dim srcConn As ADODB.Connection
    Dim destConn As ADODB.Connection
    Set srcConn = New ADODB.Connection
    Set destConn = New ADODB.Connection

    ' 循环处理每一行
    For i = 1 To 6
        If Cells(i + 1, 6).Value = "Y" Then
            sourcePath = Cells(i + 1, 2).Value & "\" & Cells(i + 1, 3).Value
            destinationPath = Cells(i + 1, 4).Value & "\" & Cells(i + 1, 5).Value

            ' 打开源数据库和目标数据库
            srcConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sourcePath
            destConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & destinationPath

            ' 复制资料表和查询
            Dim j As Integer
            For j = LBound(tables) To UBound(tables)
                CopyTable(tables(j), srcConn, destConn)
            Next j
            For j = LBound(queries) To UBound(queries)
                CopyQuery(queries(j), srcConn, destConn)
            Next j

            ' 关闭连接
            srcConn.Close
            destConn.Close
        End If
    Next i
End Sub

Sub CopyTable(ByVal tableName As String, srcConn As ADODB.Connection, destConn As ADODB.Connection)
    ' 使用 SQL 命令复制表结构和数据
    Dim sql As String
    sql = "SELECT * INTO [" & tableName & "] IN '" & destConn.ConnectionString & "' FROM [" & tableName & "]"
    srcConn.Execute sql
End Sub

Sub CopyQuery(ByVal queryName As String, srcConn As ADODB.Connection, destConn As ADODB.Connection)
    ' 复制查询定义
    Dim queryDef As ADODB.Command
    Set queryDef = New ADODB.Command
    queryDef.ActiveConnection = srcConn
    queryDef.CommandText = "SELECT * FROM [" & queryName & "]"
    queryDef.CommandType = adCmdText
    Dim rs As ADODB.Recordset
    Set rs = queryDef.Execute
    ' 创建新查询
    destConn.Execute "CREATE VIEW [" & queryName & "] AS " & queryDef.CommandText
End Sub

Sub CopyTable(ByVal tableName As String, srcConn As ADODB.Connection, dstConn As ADODB.Connection)
    ' 检查目标数据库中是否已存在该表,如果存在则删除
    If TableExists(tableName, dstConn) Then
        dstConn.Execute "DROP TABLE [" & tableName & "]"
    End If
    
    ' 使用 SQL 命令复制表结构和数据
    Dim sql As String
    sql = "SELECT * INTO [" & tableName & "] IN '" & dstConn.Properties("Data Source").Value & "' FROM [" & tableName & "]"
    srcConn.Execute sql
End Sub

Function TableExists(tableName As String, conn As ADODB.Connection) As Boolean
    Dim rs As ADODB.Recordset
    
    Set rs = conn.OpenSchema(adSchemaTables)
    rs.Filter = "TABLE_NAME='" & tableName & "'"
    TableExists = Not rs.EOF
    rs.Close
End Function

Sub CopyQuery(ByVal queryName As String, srcConn As ADODB.Connection, dstConn As ADODB.Connection)
    ' 检查目标数据库中是否已存在该查询，如果存在则删除
    If QueryExists(queryName, dstConn) Then
        dstConn.Execute "DROP VIEW [" & queryName & "]"
    End If
    
    ' 获取源数据库中查询的定义
    Dim srcCmd As ADODB.Command
    Set srcCmd = New ADODB.Command
    srcCmd.ActiveConnection = srcConn
    srcCmd.CommandText = "SELECT Top 1 * FROM MSysObjects WHERE [Name]='" & queryName & "' And Type In (-1, 5)"
    srcCmd.CommandType = adCmdText
    
    Dim rs As ADODB.Recordset
    Set rs = srcCmd.Execute
    If Not rs.EOF Then
        Dim queryDefSQL As String
        queryDefSQL = rs.Fields("SQL").Value
        
        ' 在目标数据库中创建查询
        Dim dstCmd As ADODB.Command
        Set dstCmd = New ADODB.Command
        dstCmd.ActiveConnection = dstConn
        dstCmd.CommandText = "CREATE VIEW [" & queryName & "] AS " & queryDefSQL
        dstCmd.Execute
    Else
        MsgBox "Query definition not found."
    End If
End Sub

Function QueryExists(queryName As String, conn As ADODB.Connection) As Boolean
    Dim rs As ADODB.Recordset
    Set rs = conn.OpenSchema(adSchemaViews)
    rs.Filter = "TABLE_NAME='" & queryName & "'"
    QueryExists = Not rs.EOF
    rs.Close
End Function

这个新版本的主要改进如下:

新增了一个QueryExists函数,用于检查目标数据库中是否已存在指定的查询。它的实现方式与TableExists函数类似。

反馈二

通过在目标 Access 数据库中部署 VBA 代码来处理新建查询和复制查询的 SQL 语句的过程。这种方法将查询创建和管理的逻辑封装在目标数据库内部，可以有效规遍无法直接访问 MSysObjects 表的问题。

步骤 1: 在目标 Access 数据库中创建 VBA 函数

首先，您需要在目标 Access 数据库中创建 VBA 函数来处理表和查询的复制操作。这些函数将直接在 Access 中执行，以避免通过 Excel 来直接读取 MSysObjects。

1. 复制查询的函数:

Public Sub CopyQueryToAccess(queryName As String, srcConnString As String)
    Dim srcConn As New ADODB.Connection
    Dim dstConn As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim dstCmd As ADODB.Command
    Dim queryDefSQL As String

    ' 打开源数据库连接
    srcConn.Open srcConnString
    dstConn.Open CurrentProject.Connection

    ' 检查目标数据库中是否已存在该查询，如果存在则删除
    If QueryExists(queryName, dstConn) Then
        dstConn.Execute "DROP VIEW [" & queryName & "]"
    End If

    ' 获取源数据库中查询的定义
    Set rs = srcConn.OpenSchema(adSchemaViews, Array(Empty, Empty, queryName))
    If Not rs.EOF Then
        queryDefSQL = rs!VIEW_DEFINITION

        ' 在目标数据库中创建查询
        Set dstCmd = New ADODB.Command
        dstCmd.ActiveConnection = dstConn
        dstCmd.CommandText = "CREATE VIEW [" & queryName & "] AS " & queryDefSQL
        dstCmd.Execute
    Else
        MsgBox "Query definition not found."
    End If

    srcConn.Close
    dstConn.Close
End Sub

2. 检查查询是否存在的函数:

Public Function QueryExists(queryName As String, conn As ADODB.Connection) As Boolean
    Dim rs As ADODB.Recordset
    Set rs = conn.OpenSchema(adSchemaViews)
    rs.Filter = "TABLE_NAME='" & queryName & "'"
    QueryExists = Not rs.EOF
    rs.Close
End Function

步骤 2: 在 Excel VBA 中调用 Access VBA 函数

在 Excel VBA 中，您可以使用 Access.Application 对象来打开目标 Access 数据库，并调用其中的 VBA 函数。

调用 Access 中的函数:

Sub CopyDatabaseObjectsUsingADO()
    Dim tables() As Variant
    Dim queries() As Variant
    tables = Array("Table1", "Table2")
    queries = Array("Query1", "Query2")

    Dim i As Integer
    Dim sourcePath As String
    Dim destinationPath As String
    Dim accApp As Object ' Access.Application 对象

    ' 循环处理每一行
    For i = 1 To 6
        If Cells(i + 1, 6).Value = "Y" Then
            sourcePath = Cells(i + 1, 2).Value & "\" & Cells(i + 1, 3).Value
            destinationPath = Cells(i + 1, 4).Value & "\" & Cells(i + 1, 5).Value

            ' 创建 Access 应用程序对象并打开目标数据库
            Set accApp = CreateObject("Access.Application")
            accApp.OpenCurrentDatabase destinationPath

            ' 复制资料表和查询
            Dim j As Integer
            For j = LBound(tables) To UBound(tables)
                accApp.Run "CopyTableToAccess", tables(j), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sourcePath
            Next j
            For j = LBound(queries) To UBound(queries)
                accApp.Run "CopyQueryToAccess", queries(j), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sourcePath
            Next j

            ' 关闭 Access 应用程序
            accApp.CloseCurrentDatabase
            Set accApp = Nothing
        End If
    Next i
End Sub