帮忙修改一下代码，改成可以合并子文件夹里的所有工作簿

海底拾贝

现在的代码只能合并“数据”文件夹下的工作簿，不能合并子文件夹里的工作簿。我想要的效果是能自动合并“数据”文件夹下所有子文件夹里的所有工作簿，子文件夹数量不确定可能很多几十个或者一百多个，每个子文件夹里的工作簿可能也会有几百个或几十个。请问这个代码如何修改呢？

lsc900707

近几天都有类似的求助帖，找找其中的答案参考。

乐乐2006201505

如果你原来提取数据代码合适，现在就可以提取所有合并子文件夹里的所有工作簿数据了。你试试。

海底拾贝

lsc900707 发表于 2017-3-21 10:19
近几天都有类似的求助帖，找找其中的答案参考。

是遍历文件夹吗？

海底拾贝

乐乐2006201505 发表于 2017-3-21 11:16
如果你原来提取数据代码合适，现在就可以提取所有合并子文件夹里的所有工作簿数据了。你试试。

谢谢帮助，使用正常

乐乐2006201505

不客气，好用的话给朵花。

lsc900707

海底拾贝 发表于 2017-3-21 15:08
是遍历文件夹吗？

1. Sub lsc()
   
2.     Dim tim1 As Date, tim2 As Date: tim1 = Timer
   
3.     Dim mypath, myfile, m, j, wb, arr()
   
4.     Application.ScreenUpdating = False
   
5.     Sheet1.UsedRange.Offset(1, 0).ClearContents
   
6.     mypath = ThisWorkbook.Path & "\数据"
   
7.     myfile = Dir(mypath, vbDirectory)
   
8.     Do While myfile <> ""
   
9.         If myfile <> "." And myfile <> ".." Then
   
10.             If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then
    
11.                 m = m + 1
    
12.                 ReDim Preserve arr(m)
    
13.                 arr(m) = mypath & myfile & ""
    
14.             End If
    
15.         End If
    
16.         myfile = Dir
    
17.     Loop
    
18.     For j = 1 To m
    
19.         myfile = Dir(arr(j) & "*.xls*")
    
20.         While myfile <> ""
    
21.             Set wb = CreateObject(arr(j) & myfile)
    
22.             With CreateObject(arr(j) & myfile)
    
23.             k = .Sheets(1).UsedRange.Rows.Count + 3
    
24.                 a = .Sheets(1).Range("A5:G" & k)
    
25.                 s = Split(myfile, ".")(0)
    
26.                 .Close False
    
27.             End With
    
28.             With Sheet1
    
29.                 .Range("A" & [b65536].End(3).Row + 1).Resize(UBound(a), UBound(a, 2)) = a
    
30.                 .Range("H" & .[h65536].End(3).Row + 1).Resize(UBound(a)) = s
    
31.             End With
    
32.             myfile = Dir()
    
33.         Wend
    
34.     Next
    
35.     Set wb = Nothing
    
36.     Application.ScreenUpdating = True
    
37.     tim2 = Timer
    
38.     MsgBox Format(tim2 - tim1, "合并完成，耗时：0.00秒"), 64, "温馨提示"
    
39. End Sub

复制代码

jjmysjg

lsc900707 发表于 2017-3-21 16:42

谢谢，
If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then无法运行。
麻烦老师看看

lsc900707

jjmysjg 发表于 2017-3-21 19:05
谢谢，
If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then无法运行。
麻烦老师看看

win10+office2013环境下测试正常>>>>>>>>

海底拾贝

jjmysjg 发表于 2017-3-21 19:05
谢谢，
If (GetAttr(mypath & myfile) And vbDirectory) = vbDirectory Then无法运行。
麻烦老师看看

这句添加一个斜杠 mypath = ThisWorkbook.Path & "\数据\"
这句添加一个斜杠 arr(m) = mypath & myfile & "\"

他写的代码没问题，只是这个系统保存代码会丢失数据，我刚才插入了好几次代码只要保存提交，系统都会把这两个斜杠丢失，看附件吧。