合并所有文件夹中的EXCEL文件

张雄友

合并所有文件夹中的EXCEL文件(包括子文件夹）：

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show = False Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With


只可以合并当前文件夹的EXCEL ，但对于子文件夹如附件中的《1》文件夹，《2》文件夹中的，EXCEL 文件怎么无法合并？

liulang0808

http://club.excelhome.net/thread-1165866-1-1.html
参考下这个帖子吧

zhaogang1960

请参考：

1. Sub 多表合并() '怎么不可以合并多个文件夹的？
   
2.     Dim Fso As Object, Folder As Object, arrf$(), mf&
   
3.     Dim sh As Worksheet, arr, brr(0 To 100000, 0 To 50), w As WorksheetFunction
   
4.     Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = False Then Exit Sub
   
8.         MyPath = .SelectedItems(1)
   
9.     End With
   
10.     Application.ScreenUpdating = False
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     Set w = Application.WorksheetFunction
    
13.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
14.     Set Folder = Fso.GetFolder(MyPath)
    
15.     Call GetFiles(Folder, arrf, mf)
    
16.     For l = 1 To mf
    
17.         With GetObject(arrf(l))
    
18.             For Each sh In .Worksheets
    
19.                 If w.CountA(sh.UsedRange) Then
    
20.                     Set c = sh.UsedRange
    
21.                     arr = c.Value
    
22.                     For j = 1 To UBound(arr, 2)
    
23.                         If Len(arr(1, j)) Then
    
24.                             If Not d.Exists(arr(1, j)) Then
    
25.                                 n = n + 1
    
26.                                 d(arr(1, j)) = n
    
27.                                 brr(0, n) = arr(1, j)
    
28.                             End If
    
29.                         End If
    
30.                     Next
    
31.                     For i = 2 To UBound(arr)
    
32.                         m = m + 1
    
33.                         If m > 1048575 Then
    
34.                             MsgBox "超出最大行数1048576，无法合并"
    
35.                             Exit Sub
    
36.                         End If
    
37.                         brr(m, d(arr(1, 1))) = arr(i, 1)
    
38.                         brr(m, 0) = sh.Name
    
39.                         For j = 2 To UBound(arr, 2)
    
40.                             If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
    
41.                         Next
    
42.                     Next
    
43.                 End If
    
44.             Next
    
45.             .Close False
    
46.         End With
    
47.     Next
    
48.     Cells.ClearContents
    
49.     brr(0, 0) = "表名"
    
50.     If m Then [a1].Resize(m + 1, n + 1) = brr
    
51.     Application.ScreenUpdating = True
    
52. End Sub
    
53. 
    
54. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
55.     Dim SubFolder As Object
    
56.     Dim File As Object
    
57.     For Each File In Folder.Files
    
58.         If File.Name Like "*.xlsx" Then
    
59.             mf = mf + 1
    
60.             ReDim Preserve arrf(1 To mf)
    
61.             arrf(mf) = File
    
62.         End If
    
63.     Next
    
64.     For Each SubFolder In Folder.SubFolders
    
65.         Call GetFiles(SubFolder, arrf, mf)
    
66.     Next
    
67. End Sub

复制代码

zhaogang1960

请测试附件
data.rar (38.78 KB, 下载次数: 50)

2014-11-24 23:05 上传

点击文件名下载附件

jjmysjg

zhaogang1960 发表于 2014-11-24 23:06
请测试附件

zhaogang1960版主你好：
能在汇总表的前面添加文件夹和工作簿名称吗

zhaogang1960

jjmysjg 发表于 2014-11-25 10:36
zhaogang1960版主你好：
能在汇总表的前面添加文件夹和工作簿名称吗

1. Sub 多表合并()
   
2.     Dim Fso As Object, Folder As Object, arrf$(), mf&
   
3.     Dim sh As Worksheet, arr, brr(0 To 100000, -2 To 50), w As WorksheetFunction
   
4.     Dim d As Object, i&, j&, m&, n&, c As Range, MyPath$
   
5.     With Application.FileDialog(msoFileDialogFolderPicker)
   
6.         .InitialFileName = ThisWorkbook.Path & ""
   
7.         If .Show = False Then Exit Sub
   
8.         MyPath = .SelectedItems(1)
   
9.     End With
   
10.     Application.ScreenUpdating = False
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     Set w = Application.WorksheetFunction
    
13.     Set Fso = CreateObject("Scripting.FileSystemObject")
    
14.     Set Folder = Fso.GetFolder(MyPath)
    
15.     Call GetFiles(Folder, arrf, mf)
    
16.     For l = 1 To mf
    
17.         With GetObject(arrf(2, l) & "" & arrf(1, l))
    
18.             For Each sh In .Worksheets
    
19.                 If w.CountA(sh.UsedRange) Then
    
20.                     Set c = sh.UsedRange
    
21.                     arr = c.Value
    
22.                     For j = 1 To UBound(arr, 2)
    
23.                         If Len(arr(1, j)) Then
    
24.                             If Not d.Exists(arr(1, j)) Then
    
25.                                 n = n + 1
    
26.                                 d(arr(1, j)) = n
    
27.                                 brr(0, n) = arr(1, j)
    
28.                             End If
    
29.                         End If
    
30.                     Next
    
31.                     For i = 2 To UBound(arr)
    
32.                         m = m + 1
    
33.                         If m > 1048575 Then
    
34.                             MsgBox "超出最大行数1048576，无法合并"
    
35.                             Exit Sub
    
36.                         End If
    
37.                         brr(m, d(arr(1, 1))) = arr(i, 1)
    
38.                         brr(m, -2) = Split(arrf(2, l), "")(UBound(Split(arrf(2, l), "")))
    
39.                         brr(m, -1) = arrf(1, l)
    
40.                         brr(m, 0) = sh.Name
    
41.                         For j = 2 To UBound(arr, 2)
    
42.                             If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
    
43.                         Next
    
44.                     Next
    
45.                 End If
    
46.             Next
    
47.             .Close False
    
48.         End With
    
49.     Next
    
50.     Cells.ClearContents
    
51.     brr(0, -2) = "文件夹名"
    
52.     brr(0, -1) = "工作簿名"
    
53.     brr(0, 0) = "表名"
    
54.     If m Then [a1].Resize(m + 1, n + 3) = brr
    
55.     Set Folder = Nothing
    
56.     Set Fso = Nothing
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    
59. 
    
60. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
61.     Dim SubFolder As Object
    
62.     Dim File As Object
    
63.     For Each File In Folder.Files
    
64.         If File.Name Like "*.xlsx" Then
    
65.             mf = mf + 1
    
66.             ReDim Preserve arrf(1 To 2, 1 To mf)
    
67.             arrf(1, mf) = File.Name
    
68.             arrf(2, mf) = Folder.Path
    
69.         End If
    
70.     Next
    
71.     For Each SubFolder In Folder.SubFolders
    
72.         Call GetFiles(SubFolder, arrf, mf)
    
73.     Next
    
74. End Sub
    
75. 
    

复制代码

zhaogang1960

请测试附件
data.rar (38.16 KB, 下载次数: 42)

2014-11-25 18:39 上传

点击文件名下载附件

zhaogang1960

zhaogang1960 发表于 2014-11-25 18:39
请测试附件

1. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
   
2.     Dim SubFolder As Object
   
3.     Dim File As Object
   
4.     For Each File In Folder.Files
   
5.         If File.Name Like "*.xls*" And InStr(File.Name, ThisWorkbook.Name) = 0 Then
   
6.             mf = mf + 1
   
7.             ReDim Preserve arrf(1 To 2, 1 To mf)
   
8.             arrf(1, mf) = File.Name
   
9.             arrf(2, mf) = Folder.Path
   
10.         End If
    
11.     Next
    
12.     For Each SubFolder In Folder.SubFolders
    
13.         Call GetFiles(SubFolder, arrf, mf)
    
14.     Next
    
15. End Sub
    

复制代码

zhaogang1960

下面附件中有一个文件是xls类型
data.rar (39.1 KB, 下载次数: 51)

2014-11-25 18:50 上传

点击文件名下载附件

zhaogang1960

zhaogang1960 发表于 2014-11-25 18:50
下面附件中有一个文件是xls类型

张雄友  文件夹名不能有小数点的，如果文件夹名有小数点，《1.0》，则提取后的文件夹名变成了 《1》，.0不见了。

这可不是程序引起的，不信你可以往单元格中输入2.0试试看，把该列格式设置为文本即可