不打开工作簿读取数据，以下举例都为《Excel·VBA合并工作簿》中 7，合并子文件夹同名工作簿中同名工作表，纵向汇总数据所举例的工作簿，使用Office 2019运行代码

查询遍历写入数组

Sub ADO查询遍历写入数组()'读取指定工作簿的指定工作表，工作簿可处于打开状态Dim cnn As Object, rs As Object, sqlstr$, i&, j&, arr, fp$, ws$, xfp = "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=" & fpsqlstr = "SELECT * FROM [" & ws & "$]"rs.Open sqlstr, cnn, 1, 3  '1键集游标adOpenKeyset，3逐条记录乐观锁定adLockOptimisticReDim 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.EOFi = i + 1: j = 0For Each x In rs.Fieldsj = j + 1: arr(i, j) = x.ValueNextrs.MoveNextLoop[a1].Resize(UBound(arr), UBound(arr, 2)) = arrrs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing  '关闭连接、释放对象
End Sub

读取的工作表“A级”数据（不含第1行表头）写入当前工作表

查询整体写入数组

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=" & fpsqlstr = "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

代码运行结果与之前一致

查询工作簿所有工作表名称

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=" & fpSet rs = cnn.OpenSchema(20)Do Until rs.EOFIf rs.Fields("TABLE_TYPE") = "TABLE" Thens = Replace(rs("TABLE_NAME").Value, "'", "")  '表名以数字开头时有多余的单引号，如“1月”If Right(s, 1) = "$" Then s = Left(s, Len(s) - 1): Debug.Print s  '排除无效表名及结尾的$End Ifrs.MoveNextLooprs.Close: cnn.Close: Set rs = Nothing: Set cnn = Nothing
End Sub

查询工作簿所有工作表数据

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 = TimerSet 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=" & fpSet rs = cnn.OpenSchema(20)Do Until rs.EOF  '获取所有工作表名称If rs.Fields("TABLE_TYPE") = "TABLE" Thens = Replace(rs("TABLE_NAME").Value, "'", "")If Right(s, 1) = "$" Then s = Left(s, Len(s) - 1): ss = ss & delimiter & sEnd Ifrs.MoveNextLoopr = 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  '下次写入行号Nextrs.Close: cnn.Close: Set rs = Nothing: Set cnn = NothingDebug.Print "获取写入完成，用时：" & Format(Timer - tm, "0.00")
End Sub

Hdr=no，即获取第1行表头数据，写入当前工作表