Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1983|回复: 3

[已解决]实现另存为代码正常运行

[复制链接]
发表于 2016-6-23 11:06 | 显示全部楼层 |阅读模式
本帖最后由 乐乐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:30
本帖最后由 老司机带带我 于 2016-6-23 15:34 编辑
  1. Sub SearchFiles(ByVal fd As Folder)
  2. Dim fl As File
  3. Dim sfd As Folder
  4. For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
  5. cntFiles = cntFiles + 1
  6. ArrFiles(cntFiles) = fl.Path
  7.     If fl Like "*.xls" Then
  8.         Workbooks.Open fl
  9.         With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
  10.             .InsertLines 1, "sub test()"
  11.             .InsertLines 2, "msgbox ""just a test"""            '双引号中的双引号,2个代表1个.
  12.             .InsertLines 3, "end sub"
  13.         End With
  14.         ActiveWorkbook.SaveAs Filename:=Replace(fl, ".xls", ".xlsm"), FileFormat:=52
  15.         ActiveWorkbook.Close True
  16.     End If
  17. Next fl
  18. If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹(包括隐藏文件夹和系统文件夹)组成的 Folders 集合
  19. For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
  20. SearchFiles sfd                                             '使用递归方法查找下一个文件夹
  21. Next
  22. End Sub
复制代码

写入代码多层子文件夹.rar

666.34 KB, 下载次数: 12

发表于 2016-6-23 15:30 | 显示全部楼层    本楼为最佳答案   
本帖最后由 老司机带带我 于 2016-6-23 15:34 编辑
  1. Sub SearchFiles(ByVal fd As Folder)
  2. Dim fl As File
  3. Dim sfd As Folder
  4. For Each fl In fd.Files                                        '通过循环把文件逐个放在数组内
  5. cntFiles = cntFiles + 1
  6. ArrFiles(cntFiles) = fl.Path
  7.     If fl Like "*.xls" Then
  8.         Workbooks.Open fl
  9.         With ActiveWorkbook.VBProject.VBComponents("thisworkbook").CodeModule
  10.             .InsertLines 1, "sub test()"
  11.             .InsertLines 2, "msgbox ""just a test"""            '双引号中的双引号,2个代表1个.
  12.             .InsertLines 3, "end sub"
  13.         End With
  14.         ActiveWorkbook.SaveAs Filename:=Replace(fl, ".xls", ".xlsm"), FileFormat:=52
  15.         ActiveWorkbook.Close True
  16.     End If
  17. Next fl
  18. If fd.SubFolders.Count = 0 Then Exit Sub                    'SubFolders返回由指定文件夹中所有子文件夹(包括隐藏文件夹和系统文件夹)组成的 Folders 集合
  19. For Each sfd In fd.SubFolders                               '在 Folders 集合进行循环查找
  20. SearchFiles sfd                                             '使用递归方法查找下一个文件夹
  21. Next
  22. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-6-23 22:08 | 显示全部楼层
本帖最后由 乐乐2006201506 于 2016-6-23 22:19 编辑

另存为问题.png 下面代码为什么会出现图中所示情况?
而且这个代码只能删除.xlsm文件"thisworkbook"中代码,但却无法删除.xls文件"thisworkbook"中代码。
还有就是If fl Like "*.xls" Then 代码中的like法是不是无法区分.xlsm和.xls文件。
Dim ArrFiles(1 To 10000) '创建一个数组空间,用来存放文件名称
Dim cntFiles% '文件个数
Public Sub deleteAllFiles()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

Dim strPath$                                                        '声明文件路径
Dim i%
'Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New FileSystemObject, fd As Folder                       '创建一个FileSystemObject对象和一个文件夹对象
        strPath = "C:\Users\YYB\Desktop\写入代码多层子文件夹\花名册测试文件\" '"设置要遍历的文件夹目录
        cntFiles = 0
        Set fd = fso.GetFolder(strPath)                             '设置fd文件夹对象
        SearchFiles fd                                              '调用子程序查搜索文件
'        Sheets(1).Range("A1").Resize(cntFiles) = Application.Transpose(ArrFiles)      '把数组内的路径和文件名放在单元格中
    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
             .DeleteLines 1, .CountOfLines
        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-23 22:55 | 显示全部楼层
乐乐2006201506 发表于 2016-6-23 22:08
下面代码为什么会出现图中所示情况?
而且这个代码只能删除.xlsm文件"thisworkbook"中代码,但却无法删除. ...

我这边正常啊,另外你以后如果是回复我的话用回复,不要直接在下面的框中回复,不然我不知道你回复我了!
Untitled.gif
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 13:36 , Processed in 0.529313 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表