跨文件夹合并表格问题求助

yyyeng

             有多个文件夹，每个文件夹中有一个相同文件名的表格，表格中行数不等，有几行也有几十行的。能不能帮忙汇总所有表格， 并在每行注明表格所在的文件夹名，谢谢各位大师！

gwjkkkkk

Option Explicit

Sub test()
    Dim ar, br, i&, j&, r&, ff, p$, strFileName
   
    Application.ScreenUpdating = False
    [A1].CurrentRegion.Offset(1).ClearContents
    ReDim ar(1 To 10 ^ 4, 1 To 5)
   
    p = ThisWorkbook.Path & "\"
    For Each ff In CreateObject("Scripting.FileSystemObject").GetFolder(p).subfolders
        strFileName = ff.Path & "\登记表.xlsx"
        If Dir(strFileName) <> "" Then
            With GetObject(strFileName)
                br = .Sheets(1).[A1].CurrentRegion.Value
                For i = 2 To UBound(br)
                    r = r + 1
                    ar(r, 1) = ff.Name
                    For j = 1 To UBound(br, 2)
                        ar(r, j + 1) = br(i, j)
                    Next j
                Next i
                .Close False
            End With
        End If
    Next
   
    [A2].Resize(r, UBound(ar, 2)) = ar
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

，，，，，，

limonet

关键字：subfolders+union all

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, F As Object
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    For Each F In CreateObject("scripting.filesystemobject").Getfolder(ThisWorkbook.Path).subfolders
        StrSQL = StrSQL & " Union All Select *,'" & F.Name & "' As FolderName From [Excel 12.0;DataBase=" & F.Path & "\登记表.xlsx].[Sheet1$]"
    Next F
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.18
   
2.     Dim brr(1 To 1000, 1 To 5)
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     For Each fd In fso.GetFolder(p).SubFolders
   
8.         f = p & fd.Name & "\登记表.xlsx"
   
9.         Set wb = Workbooks.Open(f, 0)
   
10.         With wb.Sheets("Sheet1")
    
11.             r = .Cells(Rows.Count, 1).End(3).Row
    
12.             arr = .[a1].Resize(r, 4)
    
13.         End With
    
14.         wb.Close 0
    
15.         For i = 2 To UBound(arr)
    
16.             m = m + 1
    
17.             brr(m, 1) = fd.Name
    
18.             For j = 1 To UBound(arr, 2)
    
19.                 brr(m, j + 1) = arr(i, j)
    
20.             Next
    
21.         Next
    
22.     Next
    
23.     With sh
    
24.         .UsedRange.Offset(1).ClearContents
    
25.         .[a2].Resize(m, 5) = brr
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码

Qs18

Sub AggregateWorksheets()
Application.ScreenUpdating = False
    Dim fso As Object
    Dim folderPath As String
    Dim folder As Object
    Dim file As Object
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim rowIndex As Long
    folderPath = ThisWorkbook.Path
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsTarget = ThisWorkbook.Worksheets(1)
    rowIndex = 2
    For Each folder In fso.GetFolder(folderPath).SubFolders
        For Each file In folder.files
            If Right(file.Name, 5) = ".xlsx" Then '仅处理 Excel 文件
                Set wbSource = Workbooks.Open(file.Path)
                Set wsSource = wbSource.Worksheets(1)
                For i = 2 To wsSource.UsedRange.Rows.Count '从第二行开始遍历数据行
                    wsTarget.Cells(rowIndex, 1) = folder.Name
                    For colIndex = 1 To wsSource.UsedRange.Columns.Count
                        wsTarget.Cells(rowIndex, colIndex + 1) = wsSource.Cells(i, colIndex)
                    Next colIndex
                    rowIndex = rowIndex + 1
                Next i
               
                wbSource.Close SaveChanges:=False
            End If
        Next file
    Next folder
Application.ScreenUpdating = True
MsgBox "合并完成！"
End Sub

jjmysjg

gwjkkkkk 发表于 2024-5-18 18:53
，，，，，，

改合并所有表,麻烦给个代码
谢谢！

gwjkkkkk

jjmysjg 发表于 2024-5-19 09:51
改合并所有表,麻烦给个代码
谢谢！

..............