Excel VBA ADO SQL入门教程023：OpenSchema获取表信息

1.

我们在使用SQL语言对数据库数据进行查询之前，有时需要获取每张表的表名，甚至获取每张表每个字段的名称等；比如，当我们进行跨工作簿数据查询及汇总时，在不打开相关工作簿的情况下，如何快速遍历指定工作簿每个工作表的名称？

——Connection对象的OpenSchema方法可以帮助我们解决此类问题；它可以从提供者获取数据库模式的信息，并返回一个只读属性、静态游标的Recordset记录集。

语法如下：

Connection.OpenSchema (QueryType, Criteria,SchemaID)

第1个参数QueryType用来指定模式查询的类型，对我们而言，常用的有两个，adSchemaTables返回给定用户可访问的表，以及adSchemaColumns返回给定用户可访问的表的列；更多类型参数大家可以自行参考ADO帮助文件。

需要重点说明的是，QueryType指定模式查询的类型常量，比如adSchemaTables，只有在ADO前期绑定的情况下才能够使用；如果ADO后期绑定，则需要使用相关的数值常量，adSchemaTables的对应值是20；adSchemaColumns的对应值是4。

第2个参数Criteria是可选的，用于限定模式查询结果的值的数组，也就是每个QueryType选项的查询限制条件数值。

第3个参数SchemaID也是可选的，为OLE DB规范未定义的提供者模式查询的GUID；如果QueryType被设置为adSchemaProviderSpecific则需要该参数，否则将不使用该参数。

第2~3参数我们基本用不到，所以照例就当没看见。

2.

举个例子。

以下代码可以在不打开相关工作簿的情况下，获得该工作簿所包含的表名及相关信息。

Sub DoOpenSchema()

    Dim Cnn As Object, Rst As Object, i As Long

    Set Cnn = CreateObject('ADODB.Connection')

    Cnn.Open 'Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data source=' & ThisWorkbook.Path & '\数据.xlsx'

    Set Rst = Cnn.OpenSchema(20)

    Cells.ClearContents

    For i = 0 To Rst.Fields.Count - 1

        Cells(1, i + 1) = Rst.Fields(i).Name

    Next

    Range('a2').CopyFromRecordset Rst

    Cnn.Close

    Set Cnn = Nothing

End Sub

代码运行结果如下：

代码说明：

Set Rst = Cnn.OpenSchema(20)，指定了我们所查询的类型，参数20对应的是adSchemaTables，也就是表。这里只能使用20作为参数，而不能使用adSchemaTables，至于原因，第一节讲过了。

结果表的第1行是Rst记录集中的字段名称，其中TABLE_NAME为表的名称，TABLE_TYPE为表的类型，DATE_CREATED为表创建的时间，DATE_MODIFIED为表结构最后修改的时间，注意是表结构最后修改的时间，不是相关表数据最后修改的时间。

另外，该段代码返回的是表的信息，而并非是工作表的信息。是的，这里的表和工作表当然并不是一个概念；表包含了定义名称、工作表等。比如标注黄色的部分，看见星光和看见月光，都是定义名称，而并非Excel工作表。

通常而言，在Excel程序中，只有表名后缀为美金符号$的才是Excel工作表。

因此，如果我们只需要获取Excel工作表的名称，并舍掉其它信息，可以将代码修改如下：

Sub DoOpenSchema2()

    Dim Cnn As Object, Rst As Object

    Dim mi As Long, s As String

    Set Cnn = CreateObject('ADODB.Connection')

    Cnn.Open 'Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data source=' & ThisWorkbook.Path & '\数据.xlsx'

    Set Rst = Cnn.OpenSchema(20)

    Cells.ClearContents

    Do Until Rst.EOF

        If Rst.Fields('TABLE_TYPE').Value = 'TABLE' Then

            s = Rst.Fields('TABLE_NAME').Value

            If Right(s, 1) = '$' Then

                i = i + 1

                Cells(i, 1) = s

            End If

            Rst.MoveNext

        End If

    Loop

    Cnn.Close

    Set Cnn = Nothing

End Sub

结果如下：

代码使用了Do Until语句循环遍历记录集，当记录集的EOF属性不为真时，先判断当前记录的TABLE_TYPE的类型是否为TABLE，如果条件成立，再判断表名的最末字符是否为$，如果条件再次成立，则将表名写入Excel，并将记录向前（MoveNext）移动一条。

……关于记录集的EOF属性我们以后讲Recordset对象时再详聊，这儿就混个面熟先。

混个面熟是很重要的事，可能关乎一生的幸福……不信……你听……

3.

再举个例子，在不打开相关工作簿的情况下，获取指定工作簿每个表的字段信息。

代码如下：

Sub DoOpenSchema3()

    Dim Cnn As Object, Rst As Object, i As Long

    Set Cnn = CreateObject('ADODB.Connection')

    Cnn.Open 'Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data source=' & ThisWorkbook.Path & '\数据.xlsx'

    Set Rst = Cnn.OpenSchema(4)

    Cells.ClearContents

    For i = 0 To Rst.Fields.Count - 1

        Cells(1, i + 1) = Rst.Fields(i).Name

    Next

    Range('a2').CopyFromRecordset Rst

    Cnn.Close

    Set Cnn = Nothing

End Sub

该段代码和第2节的第1段代码十分相似，只是将OpenSchema的参数从20改为了4，4对应的是adSchemaColumns，也就是列（字段）的信息。

结果如下：

COLUMN_NAME是字段名，TABLE_NAME是字段所属表的名称。所谓表，同样并非一定是工作表，例如看见星光和他的好兄弟看见月光。

4.

打个响指，来，咱们玩个稍微复杂点的提提神！

如果我们将第2和第3节的内容综合起来，可以解决一个很常见的表格问题：多工作表数据汇总。

多工作表数据汇总时，如果每张工作表的标题数量和排序都不一致，单纯的遍历表格+复制粘贴分表数据到总表的代码也就无济于事了，例如以下两个表，标题行的数量和排列顺序都不一样。

使用VBA+ADO+SQL的解决方案如下：

代码比较长……瞅几眼，懂不懂的就随缘吧，反正日子长长又缓缓，不急一时，总有明白的那一天。

点击【阅读原文】可以下载本章示例文件及代码~

致安

再见

Sub ADOSheetTal()

    Dim Cnn As Object, Rst As Object

    Dim d1 As Object, d2 As Object

    Dim Shtn As String, Coln As String, p As String

    Dim i As Long, x As Long, Colr, Kr

    Dim Sql As String, Ts As String

    Set Cnn = CreateObject('ADODB.Connection')

    Set d1 = CreateObject('Scripting.Dictionary')

    Set d2 = CreateObject('Scripting.Dictionary')

    p = ThisWorkbook.Path & '\数据.xlsx' '汇总工作簿的路径+名称

    Cnn.Open 'Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data source=' & p

    Set Rst = Cnn.OpenSchema(4) '读列的信息

    Do Until Rst.EOF

        Shtn = Rst.Fields('TABLE_NAME').Value '表名

        If Right(Shtn, 1) = '$' Then '判断是否工作表

            If Not d1.exists(Shtn) Then Set d1(Shtn) = CreateObject('Scripting.Dictionary')

            '嵌套字典，Shtn为d1字典key，同时为新字典的名称

            Coln = Rst.Fields('COLUMN_NAME').Value '字段名称

            d1(Shtn)(Coln) = '' '字段名装入对应工作表的字典

            If Not d2.exists(Coln) Then d2(Coln) = ''

            'd2字典记录不重复的所有表的字段名

        End If

        Rst.MoveNext

    Loop

    Kr = d1.keys '所有的表名

    Colr = d2.keys '所有表的字段名

    For i = 0 To UBound(Kr) '遍历表名

        Shtn = Kr(i): Ts = ''

        For x = 0 To UBound(Colr) '遍历字段名

            If d1(Shtn).exists(Colr(x)) Then

            '如果表中存在字段名字，则直接合并，中括号是避免字段名中存在特殊字符

                Ts = Ts & ',[' & Colr(x) & ']'

            Else

            '否则以NULL代替字段记录

                Ts = Ts & ', null as ' & Colr(x)

            End If

        Next

        Ts = Ts & ','' & Left(Shtn, Len(Shtn) - 1) & '' as 来源表名 '

        '将表名作为字段名装入字段

        Sql = Sql & 'select ' & Mid(Ts, 2) & ' from [' & Shtn & '] Union all '

        'Union语句多表合并

    Next

    Cells.ClearContents '删除汇总表数据

    [a1].Resize(1, UBound(Colr) + 1) = Colr '标题行

    [a1].Offset(0, UBound(Colr) + 1) = '来源表名'

    Range('a2').CopyFromRecordset Cnn.Execute(Left(Sql, Len(Sql) - 10))'执行Sql语句

    Set d1 = Nothing: Set d2 = Nothing

    Cnn.Close

    Set Cnn = Nothing

End Sub