求一个跨工作簿提取指定标题所有数据的VBA

ken1208

各位大神好！我有2个工作簿，"数据表"工作簿内有3个工作表！
现在需要用"提取结果"工作簿对"数据表"内每个sheet的指定标题的字段进行提取合并，如附件所示。

求一个VBA啊

ken1208

求大神帮忙看看吖

EXCELLMY

ken1208 发表于 2019-11-8 08:54
求大神帮忙看看吖

用ADO和字典做都可以，标题行位置不同而已

xiangbaoan

Option Explicit
Sub test() 'áD±êìaòaò»ÖÂ￡¬áãêÛ±íÖD ±àÂë Îa ìõÂë
Dim f$
f = ThisWorkbook.Path & "\êy¾Y±í.xlsx"
If Dir(f) <> "" Then
    Dim Cn As Object, Rs As Object, Sq$, s$
    Set Cn = CreateObject("ADODB.Connection")
    Set Rs = CreateObject("ADODB.Recordset")
    ActiveSheet.UsedRange.Offset(1).ClearContents
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & f
    Set Rs = Cn.OpenSchema(20)
    Do Until Rs.EOF
        If Rs.Fields("TABLE_TYPE") = "TABLE" Then
            s = Replace(Rs("TABLE_NAME").Value, "'", "")
                If Right(s, 1) = "$" Then
                    Sq = Sq & " UNION ALL " & "SELECT ±à&#194;&#235;,&#198;·&#195;&#251;,ê&#219;&#188;&#219;,&#189;&#248;&#188;&#219; FROM [" & s & "A1:F]"
                End If
        End If
        Rs.MoveNext
    Loop
    [a2].CopyFromRecordset Cn.Execute(Mid(Sq, 12))
    Rs.Close
    Cn.Close
    Set Cn = Nothing
    Set Rs = Nothing
End If
End Sub

xiangbaoan

………………