特殊工作簿数据合并求助？

wp2002

具体需求有劳打开其中合并工作簿需求，谢谢各位!

ykcbf1100

参与一下。

wp2002

ykcbf1100 发表于 2023-5-17 21:04
参与一下。

谢谢老师辛勒付出

limonet

代码在审核。

limonet

Sub limonet()
    Dim Cn As Object, Cat As Object, Fld As Object, F As Object, ObjSheet As Object
    Dim Path$, TmpPro$, Pro$, StrSQL$, TmpArr As Variant
    Path = ThisWorkbook.Path & "\纳税情况"
    Set Cat = CreateObject("ADOX.Catalog")
    Set Cn = CreateObject("ADODB.Connection")
    TmpPro = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
    Pro = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    Set Fld = CreateObject("Scripting.FileSystemObject").GetFolder(Path)
    For Each F In Fld.Files
        Cat.ActiveConnection = Pro & F.Path
        For Each ObjSheet In Cat.tables
            If Not ObjSheet.Name Like "*FilterDatabase" And ObjSheet.Type = "TABLE" Then
                Cn.Open TmpPro & F.Path
                StrSQL = "Select * From [" & ObjSheet.Name & "A1:A1]"
                TmpArr = Cn.Execute(StrSQL).getrows
                StrSQL = "Select '" & Split(F.Name, ".xls")(0) & "' as F1,'" & Mid(TmpArr(0, 0), 15, 18) & "' as F2,F1,F2,F3,F4,F5,F6,F7,F8,F9,F10 From [" & ObjSheet.Name & "A3:L]"
                Sheet1.Range("A" & Sheet1.Range("A9999").End(xlUp).Row + 1).CopyFromRecordset Cn.Execute(StrSQL & " Where F1<>'合计'")
                Sheet2.Range("A" & Sheet2.Range("A9999").End(xlUp).Row + 1).CopyFromRecordset Cn.Execute(StrSQL & " Where F1='合计'")
                Cn.Close
             End If
        Next ObjSheet
    Next F
End Sub

limonet

发重复了，抱歉。

wp2002

limonet 发表于 2023-5-17 21:54
代码在审核。

谢谢无私付出!

jjmysjg

ykcbf1100 发表于 2023-5-17 21:04
参与一下。

字段标题如何自动写入汇总表？
谢谢大师

ykcbf1100

jjmysjg 发表于 2023-5-18 07:20
字段标题如何自动写入汇总表？
谢谢大师

汇总表有二个表，标题不同于数据表，所以，标题需要预先做好的，是吧。

wp2002

ykcbf1100 发表于 2023-5-17 21:04
参与一下。

认真学习一下，老师的代码写得很棒!