[已解决]遍历问题

乐乐2006201506

下面公式出现了新情况，具体见图。哪位老师帮帮忙，谢谢！
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

最佳答案

月排行榜 / 总排行榜

爱疯

2016-5-11 15:51

(, 下载次数: 9)

上传

点击文件名下载附件

先试下

跳转到最佳答案楼层

乐乐2006201506

下面代码是本论坛版主爱疯为我量身打造的，遍历某一个文件夹，找到所有xlsx、xls或xlsm格式的文件（工作簿），并清除所有文件（工作簿）中所有工作表中的公式（相当于做一次只复制值的选择性粘贴）和宏。此代码可以很好的实现清除宏的效果，但对于消除公式不尽人意，主要是原来的公式部分出现了乱码的情况，希望哪位老师不吝赐教，不胜感激。

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) = "xlsx" 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
    Set wb = Workbooks.Open(myPath & "\" & myFile)
    For Each sh In wb.Sheets
        On Error Resume Next
        Set rng = sh.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
        rng.Value = rng.Value   紫色代码在去掉公式时，会将公式中的数据发生随机变化，请解决。谢谢！
        On Error GoTo 0
    Next
    wb.Close True
    Set wb = Nothing
End Sub

'删除指定文件所有模块
'http://www.excelpx.com/home/show.aspx?id=34636
Sub delCode(myPath)
    Dim wb As Workbook, c As Object
    Set wb = Workbooks.Open(myPath)

    '遍历所有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

zjdh

该附件我看过，子程序 delCode 不存在！
将该行语句删除即可，不影响附件功能。

乐乐2006201506

删除后，公式中出现乱码。

爱疯

http://www.excelpx.com/thread-417521-1-1.html

21楼的，不行吗？

乐乐2006201506

不行，有公式的表格中的数据随机就乱了。不是原来的数据。下面代码完全可以实现，能不能将之替换到你的代码中，谢谢！
Sub Macro1()
For i = 1 To Sheets.Count
    arr = Sheets(i).UsedRange
    Sheets(i).UsedRange = arr
Next
End Sub

乐乐2006201506

'指定的操作
Sub demo(myPath As String, myFile As String)
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim rng As Range
    Set wb = Workbooks.Open(myPath & "\" & myFile)
    For Each sh In wb.Sheets
        On Error Resume Next
        Set rng = sh.UsedRange.SpecialCells(xlCellTypeFormulas, 23)
        rng.Value = rng.Value   紫色代码在去掉公式时，会使公式得到的数据发生随机变化，比如，公式生成的年龄，会变为随机的数据。请解决。谢谢！
        On Error GoTo 0
    Next
    wb.Close True
    Set wb = Nothing
End Sub

爱疯

上传出错的附件看看

乐乐2006201506

麻烦您看看。

乐乐2006201506

运行后出现的问题。