多文件夹中文件合并

月舞苍穹

“各单位报表”里面有12个月的文件夹，需要把所有的文件“表头不重复的”合到一个页面，老师帮看看问题出在哪


Sub 合并()
    Dim d As Object, arr, brr(), sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 100000, 1 To 1000)
        For k = 1 To 12
            myPath = ThisWorkbook.Path & "\各单位报表\" & k & "月\"
            myName = Dir(myPath & "*.xls*")
            Do While myName <> ""
                With GetObject(myPath & myName)
                n = 1: m = 3
                    For Each sh In .Sheets
                    arr = sh.[a1].CurrentRegion
                        For i = 2 To UBound(arr)
                        n = n + 1
                            For j = 1 To UBound(arr, 2)
                                If Not d.Exists(arr(1, j)) Then
                                    m = m + 1
                                        brr(1, m) = arr(1, j)
                                        d(brr(1, m)) = m
                                End If
                                    y = d(arr(1, j))
                                    brr(n, y) = arr(i, j)
                                    brr(n, 1) = k
                                    brr(n, 2) = myName
                                    brr(n, 3) = Name
                            Next j
                        Next i
                    Next sh
                    .Close False
                End With
            myName = Dir
        Loop
        Next k
        With Sheet1
            .[a1].Resize(n, m) = brr
            .[a1] = "月份": .[b1] = "文件名": .[c1] = "表名"
        End With
End Sub

ssfx1982

仅供参考，希望对你有用

jjmysjg

ssfx1982 发表于 2024-4-23 01:29
仅供参考，希望对你有用

大师，不要“Stop”这个代码行吗

liulang0808

Sub 合并()
    Dim d As Object, arr, brr(), sh As Worksheet
    Set d = CreateObject("scripting.dictionary")
    ReDim brr(1 To 10000, 1 To 1000)
    n = 1
    m = 3
    For k = 1 To 12
        myPath = ThisWorkbook.Path & "\各单位报表\" & k & "月\"
        myName = Dir(myPath & "*.xls*")
        Do While myName <> ""
            With GetObject(myPath & myName)
               
                For Each sh In .Sheets
                    arr = sh.[a1].CurrentRegion
                    For i = 2 To UBound(arr)
                        n = n + 1
                        brr(n, 1) = k
                        brr(n, 2) = Split(myName, ".xls")(0)
                        brr(n, 3) = sh.Name
                        For j = 1 To UBound(arr, 2)
                            If Not d.Exists(arr(1, j)) Then
                                m = m + 1
                                brr(1, m) = arr(1, j)
                                d(brr(1, m)) = m
                            End If
                            y = d(arr(1, j))
                            brr(n, y) = arr(i, j)
                        Next j
                    Next i
                Next sh
                .Close False
            End With
        myName = Dir
        Loop
    Next k
    With Sheet1
        .[a1].Resize(n, m) = brr
        .[a1] = "月份": .[b1] = "文件名": .[c1] = "表名"
    End With
End Sub

ykcbf1100

参与一下，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.23
   
2.     Dim fds As New Collection
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Dim tm: tm = Timer
   
7.     Set sh = ThisWorkbook.Sheets("合并")
   
8.     p = ThisWorkbook.Path & "\各单位报表"
   
9.     getfds p, fds
   
10.     ReDim brr(1 To 10000, 1 To 100)
    
11.     n = 3: m = 1
    
12.     brr(1, 1) = "月份": brr(1, 2) = "文件名": brr(1, 3) = "表名"
    
13.     For Each fd In fds
    
14.         p1 = p & fd & ""
    
15.         For Each f In fso.GetFolder(p1).Files
    
16.             If f.Name Like "*.xls*" Then
    
17.                 If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
18.                     fn = fso.GetBaseName(f)
    
19.                     Set wb = Workbooks.Open(f, 0)
    
20.                     For Each sht In wb.Sheets
    
21.                         With sht
    
22.                             r = .Cells(Rows.Count, 1).End(3).Row
    
23.                             c = .UsedRange.Columns.Count
    
24.                             arr = .[a1].Resize(r, c)
    
25.                             bm = .Name
    
26.                         End With
    
27.                         For j = 1 To UBound(arr, 2)
    
28.                             s = arr(1, j)
    
29.                             If Not d.exists(s) Then
    
30.                                 n = n + 1
    
31.                                 d(s) = n
    
32.                                 brr(1, n) = s
    
33.                             End If
    
34.                         Next
    
35.                         For i = 2 To UBound(arr)
    
36.                             m = m + 1
    
37.                             brr(m, 1) = fd
    
38.                             brr(m, 2) = fn
    
39.                             brr(m, 3) = bm
    
40.                             For j = 1 To UBound(arr, 2)
    
41.                                 c = d(arr(1, j))
    
42.                                 brr(m, c) = brr(m, c) + arr(i, j)
    
43.                             Next
    
44.                         Next
    
45.                     Next
    
46.                     wb.Close False
    
47.                 End If
    
48.             End If
    
49.         Next f
    
50.     Next
    
51.     With sh
    
52.         .Cells.Clear
    
53.         Set Rng = .[a1].Resize(m, n)
    
54.         .[a1].Resize(1, n).Interior.Color = 49407
    
55.         With Rng
    
56.             .Value = brr
    
57.             .Borders.LineStyle = 1
    
58.             .HorizontalAlignment = xlCenter
    
59.             .VerticalAlignment = xlCenter
    
60.             .EntireColumn.AutoFit
    
61.         End With
    
62.     End With
    
63.     Set d = Nothing
    
64.     Application.ScreenUpdating = True
    
65.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
66. End Sub

复制代码

cyq4896

学习一下..

ykcbf1100

cyq4896 发表于 2024-4-23 09:33
学习一下..

好久不见。

cyq4896

ykcbf1100 发表于 2024-4-23 09:39
好久不见。

是的，你好。

baofa2

更新一下考虑更全面.zip (265.35 KB, 下载次数: 36)

2024-4-23 13:10 上传

点击文件名下载附件