怎样使VBA函数对子文件夹中的excel文件也有效？

neoleesky

昨晚我问了个问题 如何在多个excel中批量取数并填入新的表单？
http://club.excelhome.net/thread-1258421-1-1.html

chenbiao2012给了我详尽的回复。

今天跑到公司一看，发现实际的文件系统是这样的

根目录
-A子目录
--- 账单.xls
-B子目录
--- 账单.xls

-C子目录
--- 账单.xls

汇总.xls

汇总.xls在根目录下面，需要在a、b、c........等子目录的“账单.xls”中批量取数，这个该如何实现啊。


预祝各位猴年快乐！

doul123

1. Sub ListDirs(ByVal Path As String)
   
2.     Dim filename$
   
3.     Dim arrPath()
   
4.     Dim sPath$
   
5.     Dim i&, j&
   
6. 
   
7.     On Error Resume Next
   
8.     i = 1: j = 1
   
9. 
   
10.     ReDim arrPath(1 To 1)
    
11.     If Right(Path, 1) Like "[\/]" And Len(Path) > 1 Then Path = Left(Path, Len(Path) - 1)
    
12.     arrPath(i) = Path & Application.PathSeparator
    
13.     sPath = arrPath(j)
    
14. 
    
15.     Do While Len(sPath)
    
16.         filename = Dir(sPath & "*.*", vbDirectory + vbNormal)
    
17. 
    
18.         Do While Len(filename)
    
19.             If Not (filename = "." Or filename = "..") Then
    
20.                 If (GetAttr(sPath & "" & filename) And vbDirectory) = 16 Then
    
21.                     If Err.Number <> 0 Then Err.Clear: GoTo End1If
    
22.                     i = i + 1
    
23.                     ReDim Preserve arrPath(1 To i)
    
24.                     arrPath(i) = sPath & filename & Application.PathSeparator
    
25.                 End If
    
26.             End If
    
27. End1If:
    
28.             filename = Dir
    
29.         Loop
    
30.         j = j + 1
    
31.         If j > i Then Exit Do
    
32.         sPath = arrPath(j)
    
33.     Loop
    
34. End Sub
    
35. 版主写的子目录提取工具。

复制代码

deweyfbi

http://club.excelhome.net/thread-325361-1-1.html
对dir的递归调用，可以用这个里面的试试

chenbiao2012

1. Sub 汇总()
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Dim brr(1 To 1000, 1 To 4)
   
5.     p = ThisWorkbook.Path & ""
   
6.     For Each fs In fso.getfolder(p).subfolders
   
7.         For Each f In fso.getfolder(fs & "").Files
   
8.             If InStr(f.Name, "账单") Then
   
9.                 n = n + 1
   
10.                 With GetObject(f)
    
11.                     arr = .Sheets(1).UsedRange
    
12.                     .Close 0
    
13.                 End With
    
14.                 brr(n, 1) = arr(1, 2)
    
15.                 brr(n, 2) = arr(2, 2)
    
16.                 brr(n, 3) = arr(5, 4)
    
17.                 brr(n, 4) = arr(5, 2)
    
18.             End If
    
19.         Next
    
20.    Next
    
21.     With Sheets("sheet1")
    
22.         .UsedRange.Offset(1).ClearContents
    
23.         .[a2].Resize(n, 4) = brr
    
24.     End With
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

neoleesky

chenbiao2012 发表于 2016-2-6 11:13

您好，运行时报400错误。
单步测试是，报1004应用程序或对象定义错误。
请问哪里需要修改啊，谢谢！

chenbiao2012

你把附件连同代码发到我QQ上，306853590，我测试下才能知道哪儿出错了

neoleesky

chenbiao2012 发表于 2016-2-14 13:52
你把附件连同代码发到我QQ上，306853590，我测试下才能知道哪儿出错了

我公司不能使用qq，发动你的qq邮箱可以么

chenbiao2012

好的，没问题

neoleesky

chenbiao2012 发表于 2016-2-14 14:18
好的，没问题

我搞定了，非常感谢您！

LMY123

p = ThisWorkbook.Path & "\"
  For Each fs In fso.getfolder(p).subfolders
  For Each f In fso.getfolder(fs & "\").Files