目录
不打开工作簿读取数据 ，以下举例都为《Excel·VBA合并工作簿》中 7，合并子文件夹同名工作簿中同名工作表，纵向汇总数据所举例的工作簿，使用Office 2019运行代码
查询遍历写入数组
vbnet
Sub ADO查询遍历写入数组()
'读取指定工作簿的指定工作表，工作簿可处于打开状态
Dim cnn As Object, rs As Object, sqlstr$, i&, j&, arr, fp$, ws$, x
fp = "E:\测试\拆分表\合并工作簿7\广州.xlsx": ws = "A级" '工作簿路径，工作表名称
Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
'打开工作簿建立连接
'HDR=Yes，即第1行是标题，不做为数据使用，如果HDR=NO，即第1行不是标题，可做为数据使用，默认YES
'IMEX=1即读取，0为写入，2为读写
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & fp
sqlstr = "SELECT * FROM [" & ws & "$]"
rs.Open sqlstr, cnn, 1, 3 '1键集游标adOpenKeyset，3逐条记录乐观锁定adLockOptimistic
ReDim arr(1 To rs.RecordCount, 1 To rs.Fields.Count)
'--------------------for...next写法
' For i = 1 To rs.RecordCount '查询到数据行数
' For j = 1 To rs.Fields.Count '查询到数据列数
' arr(i, j) = rs.Fields(j - 1).Value
' Next
' rs.MoveNext '下一条记录
' Next
'--------------------for...each写法
' For i = 1 To rs.RecordCount
' j = 0
' For Each x In rs.Fields
' j = j + 1: arr(i, j) = x.Value
' Next
' rs.MoveNext
' Next
'--------------------do循环+for...each写法
Do Until rs.EOF
i = i + 1: j = 0
For Each x In rs.Fields
j = j + 1: arr(i, j) = x.Value
Next
rs.MoveNext
Loop
[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
rs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing '关闭连接、释放对象
End Sub读取的工作表"A级"数据（不含第1行表头）写入当前工作表
查询整体写入数组
vbnet
Sub ADO查询整体写入数组()
'读取指定工作簿的指定工作表，工作簿可处于打开状态，查询结果需要转置
Dim cnn As Object, rs As Object, sqlstr$, arr, fp$, ws$
fp = "E:\测试\拆分表\合并工作簿7\广州.xlsx": ws = "A级"
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & fp
sqlstr = "SELECT * FROM [" & ws & "$]"
'--------------------整体写入数组，转置输出
' arr = cnn.Execute(sqlstr).Getrows '将Recordset对象的多条记录检索到数组中
' [a1].Resize(UBound(arr, 2) + 1, UBound(arr) + 1) = WorksheetFunction.Transpose(arr)
'--------------------不写入数组，直接输出
Set rs = cnn.Execute(sqlstr)
[a1].CopyFromRecordset rs '输出查询结果
cnn.Close: Set cnn = Nothing
End Sub代码运行结果与之前一致
查询工作簿所有工作表名称
vbnet
Sub ADO查询工作簿所有工作表名称()
Dim cnn As Object, rs As Object, sqlstr$, fp$, s$
fp = "E:\测试\拆分表\合并工作簿7\广州.xlsx"
Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=yes;IMEX=1';data source=" & fp
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "") '表名以数字开头时有多余的单引号，如"1月"
If Right(s, 1) = "$" Then s = Left(s, Len(s) - 1): Debug.Print s '排除无效表名及结尾的$
End If
rs.MoveNext
Loop
rs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing
End Sub查询工作簿所有工作表数据
vbnet
Sub ADO查询工作簿所有工作表数据()
Dim cnn As Object, rs As Object, sqlstr$, fp$, ws, wss, s$, ss$, delimiter$, r&
fp = "E:\测试\拆分表\合并工作簿7\广州.xlsx": delimiter = Chr(28): tm = Timer
Set cnn = CreateObject("ADODB.Connection"): Set rs = CreateObject("ADODB.Recordset")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended properties='Excel 12.0 Xml;Hdr=no;IMEX=1';data source=" & fp
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF '获取所有工作表名称
If rs.Fields("TABLE_TYPE") = "TABLE" Then
s = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(s, 1) = "$" Then s = Left(s, Len(s) - 1): ss = ss & delimiter & s
End If
rs.MoveNext
Loop
r = 1: wss = Split(Mid(ss, 2), delimiter) '工作表名称数组
For Each ws In wss '遍历工作表获取数据，并写入
sqlstr = "SELECT * FROM [" & ws & "$]"
Set rs = cnn.Execute(sqlstr)
Cells(r, "a").CopyFromRecordset rs '输出查询结果
r = Cells(1, "a").CurrentRegion.Rows.Count + 1 '下次写入行号
Next
rs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing
Debug.Print "获取写入完成，用时：" & Format(Timer - tm, "0.00")
End SubHdr=no，即获取第1行表头数据，写入当前工作表
