[已解决]遍历间隔

乐乐2006201506

        怎样使下面代码在打开一个工作薄写入代码后，间隔一定时间另存，关闭，然后再打开第二个工作簿，间隔一定时间保存，关闭……以此类推。谢谢！
附件在（[已解决]实现另存为代码正常运行，http://www.excelpx.com/thread-419221-1-1.html）
Dim ArrFiles(1 To 10000)
Dim cntFiles%
Public Sub ListAllFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim strPath$
Dim i%
Dim fso As New FileSystemObject, fd As Folder
strPath = "C:\Users\Administrator\Desktop\写入代码多层子文件夹\花名册测试文件\"
cntFiles = 0
Set fd = fso.GetFolder(strPath)
SearchFiles fd
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

• Sub SearchFiles(ByVal fd As Folder)
• Dim fl As File
• Dim sfd As Folder
• For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
• cntFiles = cntFiles + 1
• ArrFiles(cntFiles) = fl.Path
•     If fl Like "*.xls" Then
•         Workbooks.Open fl
•         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:=Replace(fl, ".xls", ".xlsm"), FileFormat:=52
•         ActiveWorkbook.Close True
•     End If
• Next fl
• If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹（包括隐藏文件夹和系统文件夹）组成的 Folders 集合
• For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
• SearchFiles sfd                                             '使用递归方法查找下一个文件夹
• Next
• End Sub
  

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-24 12:12

加个延迟API函数最简单：

1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   
2. Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
   
3. Dim cntFiles% '文件个数
   
4. Public Sub ListAllFiles()
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7. 
   
8. Dim strPath$                                                        '声明文件路径
   
9. Dim i%
   
10. 'Set fso = CreateObject("Scripting.FileSystemObject")
    
11. Dim fso As New FileSystemObject, fd As Folder                       '创建一个FileSystemObject对象和一个文件夹对象
    
12.         strPath = "C:\Users\Administrator\Desktop\写入代码多层子文件夹\花名册测试文件" '"设置要遍历的文件夹目录
    
13.         cntFiles = 0
    
14.         Set fd = fso.GetFolder(strPath)                             '设置fd文件夹对象
    
15.         SearchFiles fd                                              '调用子程序查搜索文件
    
16. '        Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)      '把数组内的路径和文件名放在单元格中
    
17.     Application.DisplayAlerts = True
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    
20. Sub SearchFiles(ByVal fd As Folder)
    
21. Dim fl As File
    
22. Dim sfd As Folder
    
23. For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
    
24. cntFiles = cntFiles + 1
    
25. ArrFiles(cntFiles) = fl.Path
    
26.     If fl Like "*.xls" Then
    
27.         Workbooks.Open fl
    
28.         With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
    
29.             .InsertLines 1, "sub test()"
    
30.             .InsertLines 2, "msgbox ""just a test"""            '双引号中的双引号,2个代表1个.
    
31.             .InsertLines 3, "end sub"
    
32.         End With
    
33.         Sleep 3000   '延迟时间，毫秒
    
34.         ActiveWorkbook.SaveAs Filename:=Replace(fl, ".xls", ".xlsm"), FileFormat:=52
    
35.         ActiveWorkbook.Close True
    
36.     End If
    
37. Next fl
    
38. If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹（包括隐藏文件夹和系统文件夹）组成的 Folders 集合
    
39. For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
    
40. SearchFiles sfd                                             '使用递归方法查找下一个文件夹
    
41. Next
    
42. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

加个延迟API函数最简单：

1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
   
2. Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
   
3. Dim cntFiles% '文件个数
   
4. Public Sub ListAllFiles()
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7. 
   
8. Dim strPath$                                                        '声明文件路径
   
9. Dim i%
   
10. 'Set fso = CreateObject("Scripting.FileSystemObject")
    
11. Dim fso As New FileSystemObject, fd As Folder                       '创建一个FileSystemObject对象和一个文件夹对象
    
12.         strPath = "C:\Users\Administrator\Desktop\写入代码多层子文件夹\花名册测试文件" '"设置要遍历的文件夹目录
    
13.         cntFiles = 0
    
14.         Set fd = fso.GetFolder(strPath)                             '设置fd文件夹对象
    
15.         SearchFiles fd                                              '调用子程序查搜索文件
    
16. '        Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)      '把数组内的路径和文件名放在单元格中
    
17.     Application.DisplayAlerts = True
    
18.     Application.ScreenUpdating = True
    
19. End Sub
    
20. Sub SearchFiles(ByVal fd As Folder)
    
21. Dim fl As File
    
22. Dim sfd As Folder
    
23. For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
    
24. cntFiles = cntFiles + 1
    
25. ArrFiles(cntFiles) = fl.Path
    
26.     If fl Like "*.xls" Then
    
27.         Workbooks.Open fl
    
28.         With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
    
29.             .InsertLines 1, "sub test()"
    
30.             .InsertLines 2, "msgbox ""just a test"""            '双引号中的双引号,2个代表1个.
    
31.             .InsertLines 3, "end sub"
    
32.         End With
    
33.         Sleep 3000   '延迟时间，毫秒
    
34.         ActiveWorkbook.SaveAs Filename:=Replace(fl, ".xls", ".xlsm"), FileFormat:=52
    
35.         ActiveWorkbook.Close True
    
36.     End If
    
37. Next fl
    
38. If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹（包括隐藏文件夹和系统文件夹）组成的 Folders 集合
    
39. For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
    
40. SearchFiles sfd                                             '使用递归方法查找下一个文件夹
    
41. Next
    
42. End Sub

复制代码