注：本文首发于本人同名公众号：Excel活学活用，敬请关注！

昨天分享了一篇Excel VBA 读取Access数据库字段信息，今天继续分享如何根据储存在excel表中的字段信息，在新建数据库中批量创建表。

思路大概是这样子的：

1、新建一个数据库文件

2、根据储存的表字段信息：表名、字段名、字段类型、长度、默认值来创建表

听起来是不是很简单？现在看来，实际上也并不复杂，但在没有做出来之前，还是费了不少脑筋的，主要是自己的水平差了么一点点，很多方法都得现学现卖，少不得也跟ChatGPT进行了几轮较量，终于……长出了一口气，废话少说，还是直接上代码吧（代码有点长，解释在后面）：

Private Sub CmdSave_Click()    Dim newDB As String, newCompanyPath As String    Dim compCode As String    Dim FSO As Object    Dim cnn As Object                            '数据库连接    Dim StrCnn As String                         'ACCESS连接语句    Dim rs As Object    Dim aData(), arr()    Dim tbName As String    Dim arr1(), arr2(), arr3()    Dim catADO As Object    Dim fldName As String, dataType As String, size As String, defValue As String    Dim arrTable()    Dim tableName As String    Set catADO = CreateObject("ADOX.Catalog")    currDB = clsGT.GetDB     If Me.tbCompany = "" Or Me.TbCompAbbr = "" Or Len(Me.TbYear) <> 4 Then        MsgBox "请完整正确填写公司全称、公司简称、账套年度！"        Exit Sub    End If   Psw = clsGT.GetPsW   Set FSO = CreateObject("Scripting.FileSystemObject")    compCode = CtoPYI(Me.tbCompany)    p = Me.LbDataPath    newCompanyPath = p & "\" & Me.tbCompany    newDB = newCompanyPath & "\" & compCode & "_" & Me.TbYear & ".accdb"    If Not FSO.folderexists(newCompanyPath) Then        FSO.createfolder newCompanyPath    End If    If FSO.fileexists(newDB) Then        MsgBox "已存在账套，新建失败！"        Exit Sub    Else        catADO.Create "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";" & "Data Source=" & newDB & ";Jet OLEDB:Engine Type=5"    End If    If FSO.fileexists(newDB) Then        Application.Wait (Now + TimeValue("0:00:02")) '        Set cnn = CreateObject("ADODB.Connection")        Set rs = CreateObject("ADODB.Recordset")        StrCnn = clsGT.GetStrCnn(newDB, Psw)        cnn.Open StrCnn                          '打开数据库链接        '读取表信息数组        With Sheets("数据库表信息")            .Activate            arrTable = .UsedRange.Value        End With        iRow = UBound(arrTable, 1)        iCol = UBound(arrTable, 2)        For i = 2 To iRow            If arrTable(i, 1) <> arrTable(i - 1, 1) Then                tableName = arrTable(i, 1)                sql = "CREATE TABLE " & tableName & " (ID AUTOINCREMENT primary key,"            Else                fldName = arrTable(i, 2)                dataType = TypeNameToSQLType(arrTable(i, 3)) '数据类型                If dataType = "text" Then                    size = arrTable(i, 4)                Else                    size = ""                End If                defValue = arrTable(i, 5)        '默认值                If Len(defValue) > 0 Then                    defValue = " default " & defValue                Else                    defValue = ""                End If               '添加字段到SQL语句                sql = sql & fldName & " " & dataType                If Len(size) > 0 Then                    sql = sql & "(" & size & ")"                End If                sql = sql & defValue & ","                If i = iRow Then                    sql = Left(sql, Len(sql) - 1) & ")" '删除最后一个逗号                    cnn.Execute sql                Else                    If arrTable(i, 1) <> arrTable(i + 1, 1) Then                        sql = Left(sql, Len(sql) - 1) & ")" '删除最后一个逗号                        cnn.Execute sql                    End If                End If            End If        Next        rs.Open "tb报表类型", cnn, 1, 3        arr1 = Array("A", "B", "C")        arr2 = Array("资产负债表", "利润表", "现金流量表")        arr3 = Array("科目", "科目", "项目")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields("报表代码") = arr1(i)            rs.Fields("报表名称") = arr2(i)            rs.Fields("取数方式") = arr3(i)            rs.Update        Next        rs.Close        rs.Open "tb报表项目数据类型", cnn, 1, 3        arr1 = Array("数据项", "明细项", "小计项", "合计项", "计算项", "分类项")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields(1) = arr1(i)            rs.Update        Next        rs.Close        rs.Open "tb核算项目分类", cnn, 1, 3        arr1 = Array("XJ", "BM", "KS")        arr2 = Array("现金流量", "部门核算", "客商核算")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields("项目分类码") = arr1(i)            rs.Fields("项目分类") = arr2(i)            rs.Update        Next        rs.Close        rs.Open "tb会计制度", cnn, 1, 3        arr1 = Array("小企业", "一般企业", "小贷公司", "金融企业")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields(1) = arr1(i)            rs.Update        Next        rs.Close        rs.Open "tb基础信息", cnn, 1, 3        arr1 = Array("公司名称", "公司简称", "公司代码", "账套年度", "会计制度", "结转下年", "损益结转对方科目", "损益结转频率", "凭证制单方式")        arr2 = Array(tbCompany, TbCompAbbr, compCode, TbYear, CmbAccountingPolicy, "未结转", "", "年", "E")        arr3 = Array(0, 0, 0, 0, -1, 0, -1, -1, -1)        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields("信息名称") = arr1(i)            rs.Fields("信息值") = arr2(i)            rs.Fields("可否修改") = arr3(i)            rs.Update         Next        rs.Close        rs.Open "tb科目分类", cnn, 1, 3        arr1 = Array("1", "2", "3", "4", "5", "6", "9")        arr2 = Array("资产类", "负债类", "共同类", "所有者权益类", "成本类", "损益类", "表外类")        arr3 = Array("借", "贷", "", "贷", "借", "", "")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields("科目分类码") = arr1(i)            rs.Fields("科目分类") = arr2(i)            rs.Fields("默认方向") = arr3(i)            rs.Update         Next        rs.Close                    rs.Open "tb用户", cnn, 1, 3        rs.AddNew        rs.Fields("用户ID") = "admin"        rs.Fields("姓名") = "管理员"        rs.Fields("密码") = "111111"        rs.Fields("状态") = "正常"        rs.Fields("权限") = "管理"        rs.Update                    rs.AddNew        rs.Fields("用户ID") = "Superuser"        rs.Fields("姓名") = "超级管理员"        rs.Fields("密码") = clsGT.GetPsW        rs.Fields("状态") = "正常"        rs.Fields("权限") = "管理"        rs.Update        rs.Close                    rs.Open "tb用户权限", cnn, 1, 3        arr1 = Array("管理", "审核", "制单", "查询")        For i = LBound(arr1) To UBound(arr1)            rs.AddNew            rs.Fields(1) = arr1(i)            rs.Update        Next        rs.Close        cnn.Close        Set cnn = Nothing       MsgBox "新建账套成功！"     Else        MsgBox "新建失败！"    End If    Unload Me  End Sub

简单解释一下代码思路：

首先定义一堆变量，变量的定义方式各人喜欢，主要还是要有利于写代码、读代码，所以，我的基本原则是：

不强制声明，不喜欢被强！

循环变量不定义，

for i = 0 to 100  '这个i我一般不定义

其他有一定含义的变量还是要定义一下，基本能看出这个变量是储存什么内容的。不啰嗦了，这些内容网上一搜一大堆。

然后检查一下新建账套的要素是否填全，省得做无用功，代码也会报错。

接下来创建数据库文件，这里是有一定的命名规则的，不展开。

接着读取sheets(“数据库表信息”)内容到数组，也可以直接在excel表中循环，不过如果数据量大的话，数组要快很多，这个不用多说，数组一定要用好。

接下来关键代码来了，就是下面的一个for循环，生成创建表的SQL语句，这段代码ChatGPT功不可没。创建表的SQL语句大概是这个样子的：

 '创建凭证表            sql = "Create table tb凭证 " _                & "(ID AUTOINCREMENT primary key,日期 Date,凭证号 Integer,摘要 text(255)," _                & "科目代码 text(255),科目全称 text(255),核算项目 text(255),借方金额 double," _                & "贷方金额 double,余额 double,分录号 text(255),月份 text(255)," _                & "作废标志 Bit DEFAULT no,制单人 text(255),审核人 text(255),记账人 text(255)," _                & "月结状态 Bit DEFAULT no,项目查询 text(255))"

后面大段大段的打开具体表的记录集，写入一些记录。

基本就是这样子。

感想：之前我是一个表一个表地写出创建表的SQL语句的（就像上面这个‘创建凭证表’的代码），这样也能达到目的，不过一旦表结构、字段发生一点点变化，都要来修改SQL语句，灵活性太差，特别是在设计过程当中，经常会有变化，比较头疼。

现在好了，只要保存最新的表的信息，一切就在点点之间，感觉倍爽！

好了，今天就分享到这里，欢迎点赞分享、留言讨论，咱们下期再会！

注：本文首发于本人同名公众号：Excel活学活用，敬请关注！