合并不同文件夹下相同名称的工作簿内的工作表到同一个工作表

vince鑫15

opiona 发表于 2016-6-2 14:41

老师您好，我希望能够按同名工作簿进行分类形成新的合并工作簿，具体参照附件哈，此外不知道为什么程序跑出来后被合并的第一个工作簿中含中文的列的内容都会丢失，我把测试的结果也加到附件中了，麻烦您了

zhaogang1960

vince鑫15 发表于 2016-6-2 17:13
老师，我再尝试了下，您的程序似乎是把所有工作簿都合并到了一个工作簿内哈，我希望的结果是by相同名称的 ...

Sub ADO法()
    Dim cnn As Object, rs As Object, SQL$, Fso As Object, Folder As Object, i&, j&, l&, wb As Workbook, d As Object, k, t, arr
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set d = CreateObject("scripting.dictionary")
    Set cnn = CreateObject("adodb.connection")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(ThisWorkbook.Path & "\数据")
    Call GetFiles(Folder, d)
    Set wb = Workbooks.Add(xlWBATWorksheet)
    cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=excel 12.0;Data Source=" & ThisWorkbook.FullName
    k = d.keys
    t = d.items
    For i = 0 To d.Count - 1
        arr = Split(t(i), ",")
        With wb.Sheets(1)
            .Cells.ClearContents
            For j = 0 To UBound(arr)
                SQL = "select * from [Excel 12.0;Database=" & arr(i) & "].[Sheet1$]"
                Set rs = cnn.Execute(SQL)
                If j = 0 Then
                    For l = 1 To rs.Fields.Count
                        .Cells(1, l) = rs.Fields(l - 1).Name
                    Next
                    .[a2].CopyFromRecordset rs
                Else
                    .Range("a" & .Rows.Count).End(xlUp).Offset(1).CopyFromRecordset cnn.Execute(SQL)
                End If
            Next
            wb.SaveAs ThisWorkbook.Path & "\需要得到的结果\" & k(i)
        End With
    Next
    wb.Close
    Set Folder = Nothing
    Set Fso = Nothing
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

Sub GetFiles(ByVal Folder As Object, d As Object)
    Dim SubFolder As Object
    Dim File As Object
    For Each File In Folder.Files
        If File.Name Like "*.xlsx" Then
            If Not d.Exists(File.Name) Then
                d(File.Name) = File
            Else
                d(File.Name) = d(File.Name) & "," & File
            End If
        End If
    Next
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder, d)
    Next
End Sub

zhaogang1960

请测试附件
汇总v2.rar (677.9 KB, 下载次数: 351)

2016-6-2 17:40 上传

点击文件名下载附件

jjmysjg

留下记号，正是需要的

z601520274

opiona 发表于 2016-6-1 09:13

老师可以问下，怎么样能让文件夹下名称相同的工作簿合并成一个工作簿呢，

z601520274

opiona 发表于 2016-6-1 09:13

老师可以问下，怎么样能让文件夹下名称相同的工作簿合并成一个工作簿呢，

z601520274

opiona 发表于 2016-6-2 14:41

老师可以问下，怎么样能让文件夹下名称相同的工作簿合并成一个工作簿呢，

opiona

文件夹下名称相同的工作簿，是不可能存在的！

http://club.excelhome.net/thread-1170256-1-1.html

226cc

zhaogang1960 发表于 2016-6-2 17:41
请测试附件

需要vba实现的~~各位大能帮看看啦。谢谢
http://club.excelhome.net/thread-1316011-1-1.html
(出处: ExcelHome技术论坛)
打扰楼主了，羡慕你有能人帮你看看。不好意思啊，@zhaogang1960能帮我看看吗。。。。。

yingkongwuyu

老师好，如果在原始的excel中把sheet1工作表的名字改成了其他的，程序应该怎么进行更改呢？目的就是把文件夹中子文件夹下所有的excel更改过名字的sheet1进行数据合并到一个新的工作簿的工作表中