使用ADO在Excel和Access之间传递数据

2009年06月8日, 9:22 下午

(4 人投票, 平均: 3.25 out of 5)

Loading ...

Excel擅长于分析数据，而Access则擅长于储存和整理数量较大且复杂的数据集，因此，将这两个应用软件协同使用，充分利用各自的优势，可以创建强大的数据处理工具。
使用VBA，能够在两个应用软件之间传递一条或多条记录，也能够通过Excel更新Access数据库。有两种主要的对象模型用于与Access相交互：DAO适用于处理Jet数据库引擎，而更新且更通用的ADO则适用于为企业级的数据库传递数据，例如SQL Server和Oracle。
在开始下面的内容之前，最好先下载示例文件，以便对照学习。
示例文件下载：人口预测.xls

示例文件说明
在示例文件中，“人口预测”工作表中1950年和2000年列是每个国家的实际人口，其它列是预测的人口，当单击“创建数据库”按钮时，会在与Excel文件相同的文件夹下创建一个名为“数据库测试.mdb”的Access数据库。该数据库包含一个带有7个字段的名为tblPopulation的表。当单击“装载到Access”按钮时，将装载工作表中所有记录到Access数据库的tblPopulation表。
“新字段”工作表中具有与“人口预测”工作表相同的人口数据，但增加了一个“区域”列。单击“插入字段”按钮，将添加“区域”字段到Access数据库的tblPopulation表；单击“更新字段数据”按钮，将更新Access表中的数据，即使用工作表列C中相匹配的数据更新数据库中新创建的区域字段的数据。单击“删除字段”按钮，将删除所创建的“区域”字段。
“下载表”工作表中，单击“下载表”按钮将使用数据库表tblPopulation中的数据填充该工作表；单击“更新当前记录”，如果您修改了当前行中的某个数据，那么修改将被写入到Access表中相应的记录。
“区域”工作表中，在单元格K1中具有数据有效性列表。从列表中选择一个值将触发事件代码，然后调用相应的代码模块下载该区域所有国家的数据到该工作表中。
“前20条”工作表中，单击“下载前20条记录”按钮，将数据表中前20条记录载入工作表中。
使用ADOX创建Access数据库和表
步骤1：设置合适的库引用
在VBE中，单击“工具——引用”，选择“Microsoft ActiveX Data Objects 2.X Library”和“Microsoft ADO Ext. 2.x for DDL And Security”。
步骤2：输入代码
在模块的声明部分，声明常量：

Const TARGET_DB = "数据库测试.mdb"

然后，输入下面的代码，以创建数据库。

Sub CreateDB_And_Table()
 
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim sDB_Path As String
 
    sDB_Path = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    '如果该数据库已存在则删除
    On Error Resume Next
    Kill sDB_Path
    On Error GoTo 0
 
    '创建新数据库
    Set cat = New ADOX.Catalog
    cat.Create _
        "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & sDB_Path & ";"
 
    '创建表
    Set tbl = New ADOX.Table
    tbl.Name = "tblPopulation"
    tbl.Columns.Append "PopID", adInteger
    tbl.Columns.Append "国家", adVarWChar, 60
    tbl.Columns.Append "1950年", adDouble
    tbl.Columns.Append "2000年", adDouble
    tbl.Columns.Append "2015年", adDouble
    tbl.Columns.Append "2025年", adDouble
    tbl.Columns.Append "2050年", adDouble
    cat.Tables.Append tbl
 
    Set cat = Nothing
 
End Sub

步骤3：将CreateDB_And_Table过程关联到“创建数据库”按钮。
代码说明：上述代码首先创建一个新的Catalog，即使用ADOX引用数据库，然后创建一个名为tblPopulation的表，接着为该表添加字段，最后将该表添加到数据库中的Tables集合。
ADOX是ADO的扩展，可用来创建和修改数据库结构（表和字段），专门用来处理Jet数据库引擎。因此，使用ADOX来创建表和字段，并且很容易定义数据类型和索引值。
将工作表中的内容载入数据库表
要将工作表中的内容载入数据为表，需要完成下列步骤：
1、创建对数据库的连接。
2、定义基于表的记录集。
3、遍历列和行，一次装载一个字段数据到每条记录中。因此，对于每行，需要完成：
（1）rst.AddNew（创建一条新记录）
（2）遍历列，将值赋给记录集中的每个字段。本例中，工作表的列标题与数据库表的字段名完全相同，因此，载入数据时可以遍历标题以获取字段列表。
（3）rst.Update（保存记录）
4、最后，通过关闭Recordset和Connection对象然后将其设置为Nothing来完成清理，以避免内存泄漏。
代码如下：

Sub PushTableToAccess()
    Dim cnn As ADODB.Connection
    Dim MyConn
    Dim rst As ADODB.Recordset
    Dim i As Long, j As Long
    Dim Rw As Long
 
    '激活所需要的工作表,获取已使用的行数
    Sheets("人口预测").Activate
    Rw = Range("A65536").End(xlUp).Row
 
    '创建对数据库的连接
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    '创建记录集
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:="tblPopulation", ActiveConnection:=cnn, _
             CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
             Options:=adCmdTable
 
    '将Excel中所有的记录载入Access.
    For i = 2 To Rw
        rst.AddNew
        For j = 1 To 7
            rst(Cells(1, j).Value) = Cells(i, j).Value
        Next j
        rst.Update
    Next i
 
    ' 关闭连接并清理内存
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub

在表中创建新字段并使用新数据更新现有的记录
下面，在现有的表中创建新字段，然后将数据载入到该字段而不影响其它字段。
1、添加新字段
（1）使用ADOX添加字段
按照下面的步骤使用ADOX创建新字段：
1）创建新的ADO连接
2）创建ADOX Catalog（数据库），使该数据库使用刚创建的ADO连接
3）设置对希望修改的表的引用
4）通过追加到该表的Columns集合，添加列到表中。在创建每个字段时，需要字义数据类型。
5）清理引用。
代码如下：

Sub AddNewField_ADOX()
    Dim cnn As ADODB.Connection
    Dim MyConn
    Dim cat As ADOX.Catalog
    Dim col As ADOX.Column
    Dim tbl As ADOX.Table
    Dim sDB_Path As String
 
    MyConn = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    '连接到数据库并使用该连接创建新的ADOX Catalog
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
 
    '添加新字段
    Set tbl = cat.Tables("tblPopulation")
    tbl.Columns.Append "区域", adVarWChar, 60
 
    '清理引用
    Set cat = Nothing
    Set col = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

（2）使用SQL添加字段
还有一种方法是使用SQL修改数据库和表结构，步骤如下：
1）创建新的ADO连接
2）创建Command对象，使其使用刚创建的ADO连接
3）执行添加新字段的SQL语句，在SQL语句中定义了字段类型和大小
4）清理引用
代码如下：

Sub AddNewField_SQL()
 
    Dim cnn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim MyConn
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    '打开连接
    Set cnn = New ADODB.Connection
    With cnn
      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .Open MyConn
    End With
 
    '创建新的Command对象,并设置其Connection属性
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = cnn
    '创建字段
    cmd.CommandText = "ALTER TABLE tblPopulation ADD Column 区域 Char(30)"
    cmd.Execute
 
    '清理引用
    Set cmd = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

2、更新字段数据
要为多个记录更新字段的内容，需要遍历工作表中的行，一次修改一条记录，必须使用唯一的ID作为关键字段。步骤如下：
1）定位到正确的工作表，并确定需要载入多少行
2）创建ADO连接
3）遍历每条记录——定义当前记录中筛选过的记录集、打开记录集、修改记录、更新并关闭记录集
4）关闭连接并清理引用
代码如下：

Sub PopulateOneField()
    Dim cnn As ADODB.Connection
    Dim MyConn
    Dim rst As ADODB.Recordset
    Dim i As Long, j As Long
    Dim Rw As Long
    Dim sSQL As String
 
    Sheets("新字段").Activate
    Rw = Range("A65536").End(xlUp).Row
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    '更新表中所有记录里的某字段
    For i = 2 To Rw
        sSQL = "SELECT * FROM tblPopulation WHERE PopID = " & Cells(i, 1).Value
        rst.Open Source:=sSQL, ActiveConnection:=cnn, _
                 CursorType:=adOpenKeyset, LockType:=adLockOptimistic
            rst(Cells(1, 3).Value) = Cells(i, 3).Value
            rst.Update
        rst.Close
    Next i
 
    ' 关闭连接
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub

将Access中表的内容下载到Excel
需要完成下列步骤：
（1）创建到数据库的ADO连接
（2）定义基于tblPopulation的记录集
（3）遍历表中的字段名称并将其写入工作表的第1行
（4）使用CopyFromRecordset方法将数据库记录传递到Excel，开始于第2行。CopyFromRecordset方法比一次遍历一条记录更有效，能够一次传递上千条记录。
（5）清理引用
代码如下：

Sub TransferTableFromAccess()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim MyConn
    Dim i As Long
    Dim ShDest As Worksheet
 
    Set ShDest = Sheets("下载表")
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:="tblPopulation", ActiveConnection:=cnn, _
             CursorType:=adOpenDynamic, LockType:=adLockOptimistic, _
             Options:=adCmdTable
 
    '清除工作表中已存在的数据
    ShDest.Activate
    Range("A1").CurrentRegion.Offset(1, 0).Clear
 
    '创建字段标题
    i = 0
    With Range("A1")
        For Each fld In rst.Fields
            .Offset(0, i).Value = fld.Name
            i = i + 1
        Next fld
    End With
 
    '将数据传递到Excel
    Range("A2").CopyFromRecordset rst
 
    ' 关闭连接
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub

使用数据有效性列表从Access查询中导入数据
在“区域”工作表模块中放置下列代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    If Target = Range("K1") Then Call DownloadRegion
    Application.EnableEvents = True
End Sub

过程DownloadRegion的代码如下：

Sub DownloadRegion()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim MyConn
    Dim i As Long
    Dim ShDest As Worksheet
    Dim sSQL As String
 
    Set ShDest = Sheets("区域")
 
    sSQL = "SELECT * FROM tblPopulation WHERE 区域 ='" & ShDest.Range("K1").Value & "'"
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:=sSQL, ActiveConnection:=cnn, _
             CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, _
             Options:=adCmdText
 
    '清除工作表中已有的数据
    ShDest.Activate
    Range("A1").CurrentRegion.Clear
 
    '创建字段标题
    i = 0
    With Range("A1")
        For Each fld In rst.Fields
            .Offset(0, i).Value = fld.Name
            i = i + 1
        Next fld
    End With
 
    '将数据传递到Excel
    Range("A2").CopyFromRecordset rst
 
    ' 关闭连接
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub

在Excel中编辑某条记录，并且更新Access表
按照下列步骤：
（1）查找当前行列A中的值，确定要更新的记录的ID。
（2）创建SQL语句，筛选表到要更新的记录。
（3）创建ADO连接，并且基于SQL语句打开记录集。
（4）遍历该行中的每一列，将值写入到该条记录。因为工作表第1行中标题与数据表中的字段名相匹配，所以可以遍历标题以识别要修改的字段。
（5）关闭记录集并清理引用。
代码如下：

Sub AlterOneRecord()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim MyConn
    Dim lngRow As Long
    Dim lngID As Long
    Dim j As Long
    Dim sSQL As String
 
    '确定当前记录的ID并定义SQL语句
    lngRow = ActiveCell.Row
    lngID = Cells(lngRow, 1).Value
 
    sSQL = "SELECT * FROM tblPopulation WHERE PopID = " & lngID
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:=sSQL, ActiveConnection:=cnn, _
             CursorType:=adOpenKeyset, LockType:=adLockOptimistic
 
    '将所有记录从Excel载入到Access.
    For j = 2 To 7
        rst(Cells(1, j).Value) = Cells(lngRow, j).Value
    Next j
    rst.Update
 
    ' 关闭连接
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub

删除字段
1、使用ADOX删除字段
按照下列步骤：
（1）创建新的ADO连接。
（2）创建ADOX Catalog（数据库），并使该数据库使用刚创建的ADO连接。
（3）设置对希望修改的表的引用。
（4）通过表的Columns集合从表中删除列。
（5）清理引用。
注：要删除某字段，该字段首先必须已存在于表中。
代码如下：

Sub DeleteAField_ADOX()
    Dim cnn As ADODB.Connection
    Dim MyConn
    Dim cat As ADOX.Catalog
    Dim col As ADOX.Column
    Dim tbl As ADOX.Table
 
    MyConn = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    '连接数据库
    Set cnn = New ADODB.Connection
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = cnn
 
    '删除列
    Set tbl = cat.Tables("tblPopulation")
    tbl.Columns.Delete "区域"
 
    '清理引用
    Set cat = Nothing
    Set col = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

2、使用SQL删除字段
还有一种方法是使用SQL来删除字段。按照下列步骤：
（1）创建新的ADO连接。
（2）创建Command对象，使其使用新的ADO连接。
（3）执行SQL语句，使用DROP子句删除字段。
（4）清理引用。
代码如下：

Sub DeleteAField()
 
    Dim cnn As ADODB.Connection
    Dim cmd As ADODB.Command
    Dim MyConn
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    '打开连接
    Set cnn = New ADODB.Connection
    With cnn
      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .Open MyConn
    End With
 
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = cnn
    '删除字段
    cmd.CommandText = "ALTER TABLE tblPopulation DROP Column 区域"
    cmd.Execute
 
    '清理引用
    Set cmd = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

从数据库中提取指定数量的记录
从数据库表中获取前20条记录到工作表中的代码如下：

Sub DownloadTop20()
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim fld As ADODB.Field
    Dim MyConn
    Dim i As Long
    Dim ShDest As Worksheet
    Dim sSQL As String
 
    Set ShDest = Sheets("前20条")
 
    sSQL = "SELECT * FROM tblPopulation WHERE PopID <= 20"
 
    Set cnn = New ADODB.Connection
    MyConn = ThisWorkbook.Path & Application.PathSeparator & TARGET_DB
 
    With cnn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Open MyConn
    End With
 
    Set rst = New ADODB.Recordset
    rst.CursorLocation = adUseServer
    rst.Open Source:=sSQL, ActiveConnection:=cnn, _
             CursorType:=adOpenForwardOnly, LockType:=adLockOptimistic, _
             Options:=adCmdText
 
    '清除工作表中已有的数据
    ShDest.Activate
    Range("A1").CurrentRegion.Offset(1, 0).Clear
 
    '创建字段标题
    i = 0
    With Range("A1")
        For Each fld In rst.Fields
            .Offset(0, i).Value = fld.Name
            i = i + 1
        Next fld
    End With
 
    '将数据传递到Excel
    Range("A2").CopyFromRecordset rst
 
    ' 关闭连接
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
 
End Sub