使用VBA创建Access数据表

导读：

本期介绍如何在Access数据库中创建一张空数据表。下期将介绍如何将工作表中的数据存入数据库对应的表中，随后还将介绍如何从数据库的表中取出数据输出到Excel工作表中，以及如何在导入一个文本文件时（如信贷台账.csv），自动建立数据库，创建表，并将记录导入到数据库表中，完成Excel与Access的完美交互。

演示：

在下面的演示中，运行代码后，你将看到，在数据库中，创建了一张名为的空表，有4个字段。

代码：

Code:

Option Explicit

'需手动在VBE窗口，工具-引用 Microsoft ActiveX Data Objects 2.X Library

'声明全局变量cn

Public cn As ADODB.Connection

Public AccessDb As String '带扩展名的数据库完整路径

'****************************

'file:CreateAccTable

'author:杨开科

'fun:在Acc数据库中建表，如果存在，则删除重建

'指定带路径及扩展名的数据库完整路径，表名，带字段属性的字段名字符串

'也可在工作表或窗体中指定，而不是直接在代码中指定，需重写代码

'date:2017/12/25

'Modified By:

'****************************

'假定当前工作簿同目录中，数据库已存在

'将光标放在此过程体内任意位置，按F5，即可建出表来

'如不存在，可手工建或参阅往期推送文章【使用VBA创建Access数据库】

Sub CreateAccTable()

'变量声明

Dim strDbPath As String '数据库路径

Dim strDbName As String '数据库文件名

Dim strTable As String '表名

Dim strFields As String '带字段属性的字段名字符串

'指定路径为当前正在运行代码的工作簿的完整路径，不包括末尾的分隔符和应用程序名称

strDbPath = ThisWorkbook.Path

'指定要连接的数据库文件名

strDbName = "基础台账.accdb"

'指定数据库，如"C:\信贷台账.accdb"

AccessDb = strDbPath & "\" & strDbName

'指定要创建的数据表名称

strTable = "工资表"

'指定字段名及相关属性

'例，建客户信息表， 可用primary key将客户码指定为主键

'strFields = "客户码 text(20) primary key, 姓名 text(10)"

strFields = "身份证号码 text(18),姓名 text(10), 账号 text(50), 金额 double"

'如果数据库已连接

If AccDbConnection Then

'调用CreateTab建表，传入带文件路径及扩展名的数据库名称，表名称，字段名及其属性

Call CreateTab(AccessDb, strTable, strFields)

End If

End Sub

'****************************

'file:AccDbConnection

'author:杨开科

'fun:数据库连接

'指定数据库路径，指定数据库文件名

'date:2017/12/25

'Modified By:

'****************************

Function AccDbConnection() As Boolean

'如果发生任何错误（如,数据库不存在），则跳转

On Error GoTo ErrHand:

'new一个连接对象

Set cn = New ADODB.Connection

'Provider指定要打开的数据库驱动程序，Data Source指定数据库在计算机上的物理路径

ErrHand:

'如果出错

If err.Number Then

MsgBox "数据库" & AccessDb & "连接失败！" & vbNewLine _

& "请确认该数据库是否存在。", 4096 + 16, "错误"

Set cn = Nothing

Else

AccDbConnection = True

End If

On Error GoTo 0

End Function

'****************************

'file:CreateTab

'author:杨开科

'fun:在Acc数据库中建表，存在则删除重建

'传入参数：3个，带路径及扩展名的数据库完整路径，表名，带字段属性的字段名字符串

'date:2017/12/25

'Modified By:

'****************************

Function CreateTab(AccessDb$, strTable$, strFields$)

'使用 New 来声明对象变量，在第一次引用该变量时将新建该对象的实例

Dim rs As New ADODB.Recordset

Dim SQL As String

Dim Cmd As New ADODB.Command

' If AccDbConnection Then

'--------------------判断是否存在同名数据表,有则删除

'使用ADO OpenSchema 方法返回 Recordset 对象给变量rs

'可获取到数据库中的表名

Set rs = cn.OpenSchema(adSchemaTables)

'首次打开一个 Recordset 时，当前记录指针将指向第一个记录，

'同时 BOF 和 EOF 属性为 False

'如果没有记录，BOF 和 EOF 属性为 True。

'EOF属性：如果当前记录的位置在最后的记录之后，则返回 true，否则返回 fasle。

Do While Not rs.EOF

'' 如果表存在（表名转换为小写），则删除它

If LCase(rs!TABLE_NAME) = LCase(strTable) Then

'' 构建删除表sql语句

SQL = "drop table " & strTable

Set Cmd.ActiveConnection = cn

'' 执行删除

With Cmd

.CommandText = SQL

.Execute , , adCmdText

End With

'' 如果找到同名表，删除后及时退出Do循环

Exit Do

End If

'' 把记录指针移动到下一条记录

rs.MoveNext

Loop

' '可选，如存在同名数据表，不删除

' Do While Not rs.EOF

' '如果表存在（表名转换为小写），则删除它

' If LCase(rs!TABLE_NAME) = LCase(strTable) Then

'

' MsgBox "数据表已存在！", vbOKOnly + vbInformation, "创建数据表"

' GoTo Line

' '退出Function

' Exit Function

' End If

' '把记录指针移动到下一条记录

' rs.MoveNext

' Loop

'-----------------------建表

Set Cmd.ActiveConnection = cn

'使用CREATE TABLE 构造sql建表语句

SQL = "CREATE TABLE " & strTable & " (" & strFields & ")"

' ID autoincrement(1,1)

'使用Execute方法执行建表语句

With Cmd

.CommandText = SQL

.Execute , , adCmdText

End With

MsgBox "数据表创建成功！", vbOKOnly + vbInformation, "创建数据表"

'----------------关闭，释放对象变量

Line:

rs.Close: cn.Close

Set rs = Nothing

Set cn = Nothing

Set Cmd = Nothing

End Function

附件及源码下载：

此文已同步至【知嗒】知识号【Excel精英之家】，相关附件可下载安装【知嗒】app应用，注册一个账号，搜索并关注【Excel精英之家】，加群【Excel精英之家】下载。

说明：

【知嗒】知识号【Excel精英之家】受限较少，一天可以推送多篇文章，从文章数量看，要比微信公众号多一些，喜欢的朋友，可留意【知嗒】知识号【Excel精英之家】。

如需反馈，或有更好的解决方案，请【写留言】。