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
联系客服