|
本帖最后由 乐乐2006201506 于 2016-6-23 22:30 编辑
怎样实现红色代码正常运行,主要是路径我不知道怎么写。谢谢!
代码在模块3中。
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"""
.InsertLines 3, "end sub"
End With
' ActiveWorkbook.SaveAs Filename:=fd & Replace(fl, ".xls", ".xlsm"), FileFormat:=52
ActiveWorkbook.Close True
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub
本帖最后由 老司机带带我 于 2016-6-23 15:34 编辑
- 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
复制代码
|
|