如何将多个不同文件夹名称中的相同名称的工作簿进行合并，形成新的工作簿。

烟花巷陌

现有多个文件夹，每个文件夹中有多个名称相同的工作簿，如下图例举的“15年6月”和“15年7月”两个文件夹，文件夹中都有六个个相同名字的工作簿：《苍南缪老板》、《苍南县灵溪镇亦旭副食品商行》、《福建真柔纸业有限公司福州尼安升日用品有限公司》、《杭州桓翔贸易有限公司》、《杭州昀茂电子商务有限公司》、《何氏酒业》。

现需要将这些文件夹中存在相同名称的工作簿中的表格进行合并，形成新的工作簿，工作簿名称不变。如图所示。（不相同名称的工作簿直接引入“需要得到的结果”的文件夹中。）

新合并后的每个工作簿中就存在了多个工作表，工作表名称均需按来源的文件夹名称来进行重命名。如

说明：新合并后的工作簿中的表格是来源于几个文件夹，则就有几个工作表。如果来源于二个文件夹，就有二个工作表，总之来源于几个文件夹新合并后的工作簿中就有几个工作表。如果仅来源于一个文件夹，工作簿中就只有一个工作表，但表中名称仍然需要更改成来源文件夹的名称。
请教各位大仙如何实现？

zhaogang1960

如果不合题意，请上传附件说明：

1. Sub 按照文件名合并工作簿()
   
2.     Dim Fso As Object, Folder As Object, wb As Workbook, arr$(), m&, i&, p$, d As Object, ds As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set ds = CreateObject("scripting.dictionary")
   
5.     p = ThisWorkbook.Path & "\需要得到的结果"
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set Folder = Fso.GetFolder(ThisWorkbook.Path)
   
8.     Application.ScreenUpdating = False
   
9.     Application.DisplayAlerts = False
   
10.     Call GetFiles(Folder, arr, m, p)
    
11.     For i = 1 To m
    
12.         With Workbooks.Open(arr(2, i) & "" & arr(1, i))
    
13.             If Not d.Exists(arr(1, i)) Then
    
14.                 .Worksheets(1).Copy
    
15.                 ds(ActiveWorkbook.Name) = p & "" & arr(1, i)
    
16.                 Set d(arr(1, i)) = ActiveWorkbook
    
17.             Else
    
18.                 .Worksheets(1).Copy After:=d(arr(1, i)).Worksheets(d(arr(1, i)).Worksheets.Count)
    
19.             End If
    
20.             ActiveSheet.Name = Split(arr(2, i), "")(UBound(Split(arr(2, i), "")))
    
21.             .Close 0
    
22.         End With
    
23.     Next
    
24.     For Each wb In Workbooks
    
25.         If ds.Exists(wb.Name) Then wb.Close True, ds(wb.Name)
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "ok"
    
29.     Set Folder = Nothing
    
30.     Set Fso = Nothing
    
31. End Sub
    
32. 
    
33. Sub GetFiles(ByVal Folder As Object, arr$(), m&, p$)
    
34.     Dim SubFolder As Object
    
35.     Dim File As Object
    
36.     If Folder.Path <> ThisWorkbook.Path And Folder.Path <> p Then
    
37.         For Each File In Folder.Files
    
38.             If File.Name Like "*.xlsx" Then
    
39.                 m = m + 1
    
40.                 ReDim Preserve arr(1 To 2, 1 To m)
    
41.                 arr(1, m) = File.Name
    
42.                 arr(2, m) = Folder.Path
    
43.             End If
    
44.         Next
    
45.     End If
    
46.     For Each SubFolder In Folder.SubFolders
    
47.         Call GetFiles(SubFolder, arr, m, p)
    
48.     Next
    
49. End Sub
    

复制代码

zhaogang1960

请将需要合并工作簿的文件夹和程序所在工作簿放在同一个文件夹中，不要放不需要合并的工作簿，详见下面附件：
工作文件夹.rar (41.56 KB, 下载次数: 270)

2015-8-20 17:56 上传

点击文件名下载附件

烟花巷陌

zhaogang1960 发表于 2015-8-20 17:56
请将需要合并工作簿的文件夹和程序所在工作簿放在同一个文件夹中，不要放不需要合并的工作簿，详见下面附件 ...

谢谢大仙，正是我想要的结果

烟花巷陌

zhaogang1960 发表于 2015-8-20 17:56
请将需要合并工作簿的文件夹和程序所在工作簿放在同一个文件夹中，不要放不需要合并的工作簿，详见下面附件 ...

大仙，能不能转换成2003版的excel

烟花巷陌

大仙，能不能转换成2003版的excel

烟花巷陌

zhaogang1960 发表于 2015-8-20 17:56
请将需要合并工作簿的文件夹和程序所在工作簿放在同一个文件夹中，不要放不需要合并的工作簿，详见下面附件 ...

已经会了，能用2003版本了执行代码了

kerting

zhaogang1960 发表于 2015-8-20 17:56
请将需要合并工作簿的文件夹和程序所在工作簿放在同一个文件夹中，不要放不需要合并的工作簿，详见下面附件 ...

1. ds(ActiveWorkbook.Name) = p & "" & arr(1, i)

复制代码

大神，这句是什么意思？如果不存在时，应该是新建工作簿，我一句就是新建的作用的吗？

zhaogang1960

kerting 发表于 2015-8-21 17:15
大神，这句是什么意思？如果不存在时，应该是新建工作簿，我一句就是新建的作用的吗？

本句是记住要保存的路径+文件名，因为这时不能保存文件，否则就不能打开同名文件了，最后保存文件时会用到路径+文件名

nmcfbgttyl

这个太好了！