同文件夹里不同excel汇总

gemini8806

求助大神，如附件，同文件夹里有不同几个excel文件，每个excel文件中的sheet及表头均一样，但是每个表里填写内容不一，可能为空；每个excel的命名也不一样；需求将非汇总表的excel的内容通过VBA脚本，一键汇总到汇总表里。谢谢！

kuangben8

汇总表想要以什么样的形式体现，楼主模拟一下看看。

gemini8806

kuangben8 发表于 2019-9-6 14:42
汇总表想要以什么样的形式体现，楼主模拟一下看看。

就是汇总表里把其他表里的内容分sheet都汇总起来，详见附件~谢谢~

opel-wong

gemini8806 发表于 2019-9-6 15:57
就是汇总表里把其他表里的内容分sheet都汇总起来，详见附件~谢谢~

遍历文件夹，打开工作薄，遍历工作表，对应表名，汇总数据。
不难，就是有点繁琐，多表对多表，，

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
遍历文件资料供参考

xiangbaoan

Option Explicit
Sub test()
Dim d As Object, Cn As Object, Rs As Object, Rst As Object, p$, f$, s$, sq$, sh As Worksheet, i%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Worksheets
    If sh.Index > 1 Then sh.Delete
Next
Application.DisplayAlerts = True
Set d = CreateObject("Scripting.Dictionary")
Set Cn = CreateObject("ADODB.Connection")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & p & 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 = "Select * From [" & s & "]"
                    Set Rst = Cn.Execute(sq)
                    If Not d.Exists(s) Then
                        d(s) = Left(s, Len(s) - 1)
                        Worksheets.Add after:=Worksheets(Worksheets.Count)
                        With ActiveSheet
                            .Name = d(s)
                            For i = 0 To Rst.Fields.Count - 1
                                .[a1].Offset(0, i) = Rst.Fields(i).Name
                            Next
                            .[a2].CopyFromRecordset Rst
                        End With
                    Else
                        Worksheets(d(s)).Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset Rst
                    End If
                    Set Rst = Nothing
                End If
            End If
            Rs.MoveNext
        Loop
        Rs.Close
        Cn.Close
    End If
    f = Dir
Loop
Set d = Nothing
Set Cn = Nothing
Set Rs = Nothing
Worksheets(1).Activate
Application.ScreenUpdating = True
MsgBox "ok!", 64
End Sub

xiangbaoan

……审审更健康……

gemini8806

xiangbaoan 发表于 2019-9-8 13:19
……审审更健康……

感谢各位大神！