多个文件夹合并多个工作簿数据

发粪涂墙911

3190496160 发表于 2023-8-22 18:57
Sub ListFilesTest() '
Application.ScreenUpdating = False '
Set sht = ThisWorkbook.Worksheets("汇总 ...

感谢感谢

发粪涂墙911

扑腾 发表于 2023-8-22 17:30
下面是香川群子的经典帖子，应该可以解决你的问题
https://club.excelhome.net/forum.php?mod=viewthread& ...

3q,学习学习

ykcbf1100

练习一下

递归遍历子文件夹下的所有文件，提取数据

ykcbf1100

1. Sub ykcbf()    '//2025.3.24  '//遍历文件夹提取数据
   
2.     Application.ScreenUpdating = False
   
3.     p = ThisWorkbook.path & ""
   
4.     xm = "Sheet1"
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     sh.Cells.ClearContents
   
7.     getfds p, m, xm, sh
   
8.     Application.ScreenUpdating = True
   
9.     MsgBox "OK！"
   
10. End Sub
    
11. 
    
12. Sub getfds(p, m, xm, sh)
    
13.     Set fso = CreateObject("Scripting.FileSystemObject")
    
14.     On Error Resume Next
    
15.     For Each fd In fso.GetFolder(p).SubFolders
    
16.         For Each f In fso.GetFolder(fd).Files
    
17.             m = m + 1
    
18.             Set wb = Workbooks.Open(f, 0)
    
19.             arr = wb.Sheets(xm).UsedRange
    
20.             wb.Close 0
    
21.             If m = 1 Then
    
22.                 sh.[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
23.             Else
    
24.                 r = sh.Cells(Rows.Count, 1).End(3).Row
    
25.                 sh.Cells(r + 1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
    
26.             End If
    
27.         Next
    
28.         getfds fd.path, m, xm, sh
    
29.     Next fd
    
30.     Set fso = Nothing
    
31. End Sub
    

复制代码