[已解决]遍历文件夹及多层子文件夹所有指定文件，写入代码

乐乐2006201506

      希望可以在下面代码的基础上改进，或者另写同样结果的代码，下面代码只是遍历一层文件夹中的文件并达到相应要求，希望达到所有层文件夹中所有文件，并达到相应要求，谢谢!网上找到的自己都不会修改，看不懂，所以才在论坛上求助。谢谢！

• Sub test()
•     p = "C:\Users\Administrator\Desktop\花名册测试文件\"
•     f = Dir(p & "*.xls")
•     Do While f <> ""
•         Workbooks.Open p & f
•         With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
•             .InsertLines 1, "sub test()"
•             .InsertLines 2, "msgbox ""just a test""" '双引号中的双引号,2个代表1个.
•             .InsertLines 3, "end sub"
•         End With
•         ActiveWorkbook.SaveAs Filename:=p & Replace(f, ".xls", ".xlsm"), FileFormat:=52
•         ActiveWorkbook.Close True
•         f = Dir
•     Loop
• End Sub
  

最佳答案

月排行榜 / 总排行榜

grf1973

2016-6-23 14:44

看看这样行不行

1. 
   
2. '***********递归获取本文件夹及所有子文件夹下所有文件名，
   
3. Dim w(1 To 10000), s%
   
4. Sub test()
   
5.     p = "C:\Users\Administrator\Desktop\花名册测试文件"
   
6.     On Error Resume Next
   
7.     s = 0
   
8.     zdir p
   
9.     For i = 1 To s
   
10.         If w(i) Like "*.xls" And w(i) <> ThisWorkbook.FullName Then
    
11.             Workbooks.Open w(i)
    
12.             With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
    
13.                 .InsertLines 1, "sub test()"
    
14.                 .InsertLines 2, "msgbox ""just a test""" '双引号中的双引号,2个代表1个.
    
15.                 .InsertLines 3, "end sub"
    
16.             End With
    
17.             ActiveWorkbook.SaveAs Filename:=p & Replace(f, ".xls", ".xlsm"), FileFormat:=52
    
18.             ActiveWorkbook.Close True
    
19.         End If
    
20.     Next
    
21. End Sub
    
22. 
    
23. Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
    
24.   Set fs = CreateObject("scripting.filesystemobject")
    
25.   For Each f In fs.GetFolder(p).Files
    
26.     If f <> ThisWorkbook.FullName Then s = s + 1: w(s) = f
    
27.   Next
    
28.   For Each m In fs.GetFolder(p).SubFolders
    
29.       zdir m
    
30.   Next
    
31. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

看看这样行不行

1. 
   
2. '***********递归获取本文件夹及所有子文件夹下所有文件名，
   
3. Dim w(1 To 10000), s%
   
4. Sub test()
   
5.     p = "C:\Users\Administrator\Desktop\花名册测试文件"
   
6.     On Error Resume Next
   
7.     s = 0
   
8.     zdir p
   
9.     For i = 1 To s
   
10.         If w(i) Like "*.xls" And w(i) <> ThisWorkbook.FullName Then
    
11.             Workbooks.Open w(i)
    
12.             With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
    
13.                 .InsertLines 1, "sub test()"
    
14.                 .InsertLines 2, "msgbox ""just a test""" '双引号中的双引号,2个代表1个.
    
15.                 .InsertLines 3, "end sub"
    
16.             End With
    
17.             ActiveWorkbook.SaveAs Filename:=p & Replace(f, ".xls", ".xlsm"), FileFormat:=52
    
18.             ActiveWorkbook.Close True
    
19.         End If
    
20.     Next
    
21. End Sub
    
22. 
    
23. Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
    
24.   Set fs = CreateObject("scripting.filesystemobject")
    
25.   For Each f In fs.GetFolder(p).Files
    
26.     If f <> ThisWorkbook.FullName Then s = s + 1: w(s) = f
    
27.   Next
    
28.   For Each m In fs.GetFolder(p).SubFolders
    
29.       zdir m
    
30.   Next
    
31. End Sub
    

复制代码

乐乐2006201506

grf1973 发表于 2016-6-23 14:44
看看这样行不行

      为什么不能实现另存为.xlsm文件。只是在原来的基础上继续保存为.xls文件。

grf1973

可以的，17句改成
ActiveWorkbook.SaveAs Filename:= Replace(w(i), ".xls", ".xlsm"), FileFormat:=52

grf1973

1. Sub 宏1()
   
2. 
   
3.     ActiveWorkbook.SaveAs Filename:=Replace(ThisWorkbook.FullName, ".xls", ".xlsm"), FileFormat:=52
   
4. End Sub
   
5. 
   
6. 
   

复制代码