[已解决]合并所有文件夹中的EXCEL文件(包括子文件夹）

张雄友

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

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


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

最佳答案

月排行榜 / 总排行榜

dsmch

2014-11-25 08:23

Dim d, w, arr, brr(100000, 50), m&, n%
Sub Macro1()
Set d = CreateObject("scripting.dictionary")
Set w = Application.WorksheetFunction
Application.ScreenUpdating = False
Cells.ClearContents
m = 0: n = 0
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then zdir .SelectedItems(1) & "\"
End With
brr(0, 0) = "表名"
If m Then [A1].Resize(m + 1, n + 1) = brr
Application.ScreenUpdating = True
End Sub
Sub zdir(p)
Dim fs As Object
Set fs = CreateObject("scripting.filesystemobject")
For Each f In fs.GetFolder(p).Files
    If f <> ThisWorkbook.FullName Then
       With GetObject(f)
                For Each sh In .Worksheets
                    If w.CountA(sh.UsedRange) Then
                        arr = sh.UsedRange.Value
                        For j = 1 To UBound(arr, 2)
                            If Len(arr(1, j)) Then
                                If Not d.Exists(arr(1, j)) Then
                                    n = n + 1
                                    d(arr(1, j)) = n
                                    brr(0, n) = arr(1, j)
                                End If
                            End If
                        Next
                        For i = 2 To UBound(arr)
                            m = m + 1
                            If m > 1048575 Then
                                MsgBox "超出最大行数1048576，无法合并"
                                Exit Sub
                            End If
                            brr(m, d(arr(1, 1))) = arr(i, 1)
                            brr(m, 0) = sh.Name
                            For j = 2 To UBound(arr, 2)
                                If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Next
                    End If
                Next
                .Close 0
            End With
    End If
Next
For Each fd In fs.GetFolder(p).SubFolders
    zdir fd
Next
End Sub

跳转到最佳答案楼层

dsmch

1. Dim d, w, arr, brr(100000, 50), m&, n%
   
2. Sub Macro1()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set w = Application.WorksheetFunction
   
5. Application.ScreenUpdating = False
   
6. Cells.ClearContents
   
7. m = 0: n = 0
   
8. zdir ThisWorkbook.Path & ""
   
9. brr(0, 0) = "表名"
   
10. If m Then [A1].Resize(m + 1, n + 1) = brr
    
11. Application.ScreenUpdating = True
    
12. End Sub
    
13. Sub zdir(p)
    
14. Dim fs As Object
    
15. Set fs = CreateObject("scripting.filesystemobject")
    
16. For Each f In fs.GetFolder(p).Files
    
17.     If f <> ThisWorkbook.FullName Then
    
18.        With GetObject(f)
    
19.                 For Each sh In .Worksheets
    
20.                     If w.CountA(sh.UsedRange) Then
    
21.                         arr = sh.UsedRange.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 0
    
46.             End With
    
47.     End If
    
48. Next
    
49. For Each fd In fs.GetFolder(p).SubFolders
    
50.     zdir fd
    
51. Next
    
52. End Sub

复制代码

dsmch

………………

张雄友

dsmch 发表于 2014-11-25 04:46
………………

zdir ThisWorkbook.Path & "\"

选择文件夹的方式怎么表达？

dsmch

Dim d, w, arr, brr(100000, 50), m&, n%
Sub Macro1()
Set d = CreateObject("scripting.dictionary")
Set w = Application.WorksheetFunction
Application.ScreenUpdating = False
Cells.ClearContents
m = 0: n = 0
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then zdir .SelectedItems(1) & "\"
End With
brr(0, 0) = "表名"
If m Then [A1].Resize(m + 1, n + 1) = brr
Application.ScreenUpdating = True
End Sub
Sub zdir(p)
Dim fs As Object
Set fs = CreateObject("scripting.filesystemobject")
For Each f In fs.GetFolder(p).Files
    If f <> ThisWorkbook.FullName Then
       With GetObject(f)
                For Each sh In .Worksheets
                    If w.CountA(sh.UsedRange) Then
                        arr = sh.UsedRange.Value
                        For j = 1 To UBound(arr, 2)
                            If Len(arr(1, j)) Then
                                If Not d.Exists(arr(1, j)) Then
                                    n = n + 1
                                    d(arr(1, j)) = n
                                    brr(0, n) = arr(1, j)
                                End If
                            End If
                        Next
                        For i = 2 To UBound(arr)
                            m = m + 1
                            If m > 1048575 Then
                                MsgBox "超出最大行数1048576，无法合并"
                                Exit Sub
                            End If
                            brr(m, d(arr(1, 1))) = arr(i, 1)
                            brr(m, 0) = sh.Name
                            For j = 2 To UBound(arr, 2)
                                If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
                            Next
                        Next
                    End If
                Next
                .Close 0
            End With
    End If
Next
For Each fd In fs.GetFolder(p).SubFolders
    zdir fd
Next
End Sub

张雄友

dsmch 发表于 2014-11-25 08:23
Dim d, w, arr, brr(100000, 50), m&, n%
Sub Macro1()
Set d = CreateObject("scripting.dictionary")

03环境下测试正确，但在10环境下测试错误。

张雄友

dsmch 发表于 2014-11-25 08:23
Dim d, w, arr, brr(100000, 50), m&, n%
Sub Macro1()
Set d = CreateObject("scripting.dictionary")

难道高版本不支持   With GetObject(f)  ??

dsmch

1. Dim d, w, arr, brr(100000, 50), m&, n%
   
2. Sub Macro1()
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set w = Application.WorksheetFunction
   
5. Application.ScreenUpdating = False
   
6. Cells.ClearContents
   
7. m = 0: n = 1
   
8. With Application.FileDialog(msoFileDialogFolderPicker)
   
9.     If .Show Then zdir .SelectedItems(1) & ""
   
10. End With
    
11. brr(0, 0) = "工作簿名"
    
12. brr(0, 1) = "表名"
    
13. If m Then [A1].Resize(m + 1, n + 1) = brr
    
14. Application.ScreenUpdating = True
    
15. End Sub
    
16. Sub zdir(p)
    
17. Dim fs As Object
    
18. Set fs = CreateObject("scripting.filesystemobject")
    
19. For Each f In fs.GetFolder(p).Files
    
20.     If f <> ThisWorkbook.FullName Then
    
21.         gzb = Split(f, "")
    
22.        With GetObject(f)
    
23.                 For Each sh In .Worksheets
    
24.                     If w.CountA(sh.UsedRange) Then
    
25.                         arr = sh.UsedRange.Value
    
26.                         For j = 1 To UBound(arr, 2)
    
27.                             If Len(arr(1, j)) Then
    
28.                                 If Not d.Exists(arr(1, j)) Then
    
29.                                     n = n + 1
    
30.                                     d(arr(1, j)) = n
    
31.                                     brr(0, n) = arr(1, j)
    
32.                                 End If
    
33.                             End If
    
34.                         Next
    
35.                         For i = 2 To UBound(arr)
    
36.                             m = m + 1
    
37.                             If m > 1048575 Then
    
38.                                 MsgBox "超出最大行数1048576，无法合并"
    
39.                                 Exit Sub
    
40.                             End If
    
41.                             brr(m, d(arr(1, 1))) = arr(i, 1)
    
42.                             brr(m, 0) = gzb(UBound(gzb))
    
43.                             brr(m, 1) = sh.Name
    
44.                             For j = 2 To UBound(arr, 2)
    
45.                                 If Len(arr(1, j)) Then brr(m, d(arr(1, j))) = arr(i, j)
    
46.                             Next
    
47.                         Next
    
48.                     End If
    
49.                 Next
    
50.                 .Close 0
    
51.             End With
    
52.     End If
    
53. Next
    
54. For Each fd In fs.GetFolder(p).SubFolders
    
55.     zdir fd
    
56. Next
    
57. End Sub

复制代码

张雄友

dsmch 发表于 2014-11-25 16:34

dsmch，您怎么将文件全部转换成03  版格式？03环境测试没有问题，但在10版本测试会出现 6 楼的情况。

张雄友

dsmch 发表于 2014-11-25 08:23
Dim d, w, arr, brr(100000, 50), m&, n%
Sub Macro1()
Set d = CreateObject("scripting.dictionary")

问题是合并数据一般都有13万行，那不是用不了？