Excel·VBA使用ADO读取工作簿工作表数据

查询遍历写入数组

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行表头）写入当前工作表
在这里插入图片描述

查询整体写入数组

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

代码运行结果与之前一致

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

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

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

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 Sub