不规则表格数据汇总

sby250

帮忙汇写一个代码，谢谢。

limonet

sheet名统一用:strsql

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, FileName$
    Set Cn = CreateObject("ADODB.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        StrSQL = StrSQL & " Union All Select '" & Split(FileName, ".")(0) & "',Null,Null,* From [Excel 12.0;Hdr=no;Database=" & Path & FileName & "].[教基3113_小学$D6:D6]"
        FileName = Dir
    Loop
    Range("B2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

limonet

关键字：sheetname类似也行，那就要catalog

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Path$, FileName$, Cat As Object, ObjTable As Object
    Set Cn = CreateObject("ADODB.Connection")
    Set Cat = CreateObject("adox.catalog")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Path = ThisWorkbook.Path & "\"
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        Cat.activeconnection = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Path & FileName
        For Each ObjTable In Cat.tables
            If ObjTable.Name Like "*教基3113*" And Not ObjTable.Name Like "*xlnm*" Then
                StrSQL = StrSQL & " Union All Select '" & Split(FileName, ".")(0) & "',Null,Null,* From [Excel 12.0;Hdr=no;Database=" & Path & FileName & "].[" & ObjTable.Name & "D6:D6]"
            End If
        Next ObjTable
        FileName = Dir
    Loop
    Range("B2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

sby250

谢谢你的帮助。你的代码我看不明白。我无法修改成提取全部数据的代码。谁还能帮我一下，我的数据表格有百多个，一个一个找太费事了。

ykcbf1100

同一个学校中，各个工作簿中字段和结构都不同的，这个代码写不了。
写了一半放弃了。

fzxba

不对，字段不统一，格式乱，难搞！

补个附件难搞.zip (140.48 KB, 下载次数: 8)

2024-3-17 09:31 上传

点击文件名下载附件

shiruiqiang

这样判断可以吗？

sby250

shiruiqiang 发表于 2024-3-17 08:15
这样判断可以吗？

谢谢你的帮助。表2和表3的体音美提取的不对。但我能看懂你的代码，我可以自己改一下。万分感谢