遍历文件夹修改数据

爱疯

Option Explicit


Dim fso As Object    '模块级变量
Dim SourcePath As String
'主程序：通过递归，执行指定的操作
Sub main()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set fso = CreateObject("scripting.filesystemobject")
    '获取源路径
    SourcePath = getFolderPath("请选择源路径")
    If SourcePath = "" Then End
    '递归
    Call Recursion(SourcePath)
    '显示结果
    Shell "explorer " & SourcePath & "\", vbNormalFocus
End Sub

'获取文件夹路径
Function getFolderPath(prompt) As String
    Dim Objshell As Object, Objfolder As Object
    Set Objshell = CreateObject("Shell.Application")
    Set Objfolder = Objshell.BrowseForFolder(0, prompt, 0, 0)
    If Objfolder Is Nothing Then getFolderPath = "" Else getFolderPath = Objfolder.self.Path
    Set Objfolder = Nothing: Set Objshell = Nothing
End Function

'递归程序
Sub Recursion(myPath As String)
    Dim myFolder As Object, mySubFolder As Object, myFile As Object
    Set myFolder = fso.getfolder(myPath)
    '遍历文件夹
    For Each mySubFolder In myFolder.SubFolders
        Recursion mySubFolder.Path
    Next
    '遍历文件
    For Each myFile In myFolder.Files
        If fso.GetExtensionName(myPath & "\" & myFile) = "xls" Or _
           fso.GetExtensionName(myPath & "\" & myFile) = "xlsm" Then
            Call demo(myPath, myFile.Name)
            Call delCode(myPath & "\" & myFile.Name)
        End If
    Next
End Sub

'指定的操作
Sub demo(myPath As String, myFile As String)
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim rng As Range
    Dim c As Object

    '1）清除公式
    Set wb = Workbooks.Open(myPath & "\" & myFile)
    For Each sh In wb.Sheets
        Cells.Copy
        sh.Range("A1").PasteSpecial Paste:=xlPasteValues
    Next

    '2）删除指定文件中的代码和窗体
    '遍历所有wb中所有部件
    For Each c In wb.VBProject.VBComponents
        '如果部件c是标准模块
        If c.Type = 100 Then
            '删除部件c第1行到最后1行的代码
            c.CodeModule.DeleteLines 1, c.CodeModule.CountOfLines
        Else
            '从部件集合中删除部件c
            wb.VBProject.VBComponents.Remove c
        End If
    Next

    wb.Close True
    Set wb = Nothing
End Sub

遍历文件夹修改数据2.rar (10.49 KB, 下载次数: 9)

2016-5-10 08:51 上传

点击文件名下载附件

zjdh

奇怪了，运行出问题，难道还缺控件？

爱疯

zjdh 发表于 2016-5-10 10:16
奇怪了，运行出问题，难道还缺控件？

百度一下：

CreateObject("scripting.filesystemobject") 运行时错误'429

。。。。。。。等你弄好了，学习一下原因

zjdh

解决办法：
1. 由于某种原因系统禁用了FSO(FileSystemObject)，引用了也没用。
   只要启用fso即可，运行regsvr32 scrrun.dll即可。
2. 或将Set fso = CreateObject("scripting.filesystemobject") 改成
     Dim fso As New FileSystemObject  

乐乐2006201506

有公式的出现了上面图片中的情况，请问怎么解决？

张雄友

爱疯 发表于 2016-5-9 17:28

如果模块工程有密码删不掉的！！！

爱疯

张雄友 发表于 2016-5-11 11:55
如果模块工程有密码删不掉的！！！

VBProject：代码操作代码之常用语句
http://club.excelhome.net/thread-191823-1-1.html

张雄友

爱疯 发表于 2016-5-11 16:48
VBProject：代码操作代码之常用语句
http://club.excelhome.net/thread-191823-1-1.html

高深，看不懂……

爱疯

张雄友 发表于 2016-5-11 23:21
高深，看不懂……

你问的，在6楼

如果判断出有密码，用按键操作输入密码。

没用过，你可去试