[已解决]请老师在这个工作簿中设置代码，删除文件夹内所有工作簿中所有工作表中的代码和公...

水木

请老师在这个工作簿中设置代码，删除文件夹内所有工作簿中所有工作表中的代码和公式。谢谢！.rar (562.84 KB, 下载次数: 3)

2016-10-25 20:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

爱疯

2016-10-26 15:38

Sub test1()
    Dim p, f
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    p = ThisWorkbook.Path & "\abc\"
    f = Dir(p)
    Do While f <> ""
        Call test2(p & f)
        f = Dir
    Loop

    MsgBox "ok"
End Sub

Sub test2(mypath)
    Dim comp As Object
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim rng As Range
    Set wb = Workbooks.Open(mypath)

    '删除代码
    For Each comp In wb.VBProject.VBComponents
        If comp.Type = 100 Then
            comp.CodeModule.DeleteLines 1, comp.CodeModule.CountOfLines
        Else
            wb.VBProject.VBComponents.Remove comp
        End If
    Next

    '删除公式
    For Each sh In wb.Sheets
        For Each rng In sh.UsedRange
            If rng.HasFormula Then
                rng.Value = rng
            End If
        Next rng
    Next sh

    wb.Close True
    Set wb = Nothing
End Sub

删除.rar (572.61 KB, 下载次数: 7)

2016-10-26 15:36 上传

点击文件名下载附件




为容易看和改
1.要判断的文件都放在abc
2.删除程序放在 删除.xlsm

两者需要放在同一目录中。

跳转到最佳答案楼层

爱疯

Sub test1()
    Dim p, f
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    p = ThisWorkbook.Path & "\abc\"
    f = Dir(p)
    Do While f <> ""
        Call test2(p & f)
        f = Dir
    Loop

    MsgBox "ok"
End Sub

Sub test2(mypath)
    Dim comp As Object
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim rng As Range
    Set wb = Workbooks.Open(mypath)

    '删除代码
    For Each comp In wb.VBProject.VBComponents
        If comp.Type = 100 Then
            comp.CodeModule.DeleteLines 1, comp.CodeModule.CountOfLines
        Else
            wb.VBProject.VBComponents.Remove comp
        End If
    Next

    '删除公式
    For Each sh In wb.Sheets
        For Each rng In sh.UsedRange
            If rng.HasFormula Then
                rng.Value = rng
            End If
        Next rng
    Next sh

    wb.Close True
    Set wb = Nothing
End Sub

删除.rar (572.61 KB, 下载次数: 7)

2016-10-26 15:36 上传

点击文件名下载附件




为容易看和改
1.要判断的文件都放在abc
2.删除程序放在 删除.xlsm

两者需要放在同一目录中。