[已解决]如何批量删除文件夹内的除本文件以外的所有文件中的代码？

小雨饰品

请教：如何批量删除文件夹内的除本文件以外的所有文件中的代码？
以前zjdh老师写过一个代码，我想请各位修改或重新写一下  不要选择文件夹，就是说    点出按钮   直接将本文件夹下除本工作簿以外的所有工作簿中的代码删除。谢谢！
zjdh老师的原代码以下http://www.excelpx.com/thread-250005-1-1.html：
Sub 删除宏()  '2003可用
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Set Myf = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", &H1)
    If Not Myf Is Nothing Then
        Directory = Myf.self.Path
    End If
    MyName = Dir(Directory & "\*.xls")
    Do While MyName <> ""
        Workbooks.Open (Directory & "\" & MyName)
        With ActiveWorkbook
        '**删除各模块内容及窗体
            For Each m In .VBProject.VBComponents
                If m.Type = 100 Then
                    m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
                Else
                    .VBProject.VBComponents.Remove m
                End If
            Next
        '*****************
        .Close True
        End With
        MyName = Dir
    Loop
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-11-9 17:27

1. Sub 删除宏()  '2003可用
   
2. 
   
3.     Dim strPath As String
   
4.     Dim wb As Workbook
   
5. 
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8.     Application.EnableEvents = False
   
9.     Application.DisplayAlerts = False
   
10.     strPath = ThisWorkbook.Path & Application.PathSeparator
    
11.     myname = Dir(strPath & "*.xls")
    
12.    
    
13.     Do While myname <> ""
    
14.         If myname <> ThisWorkbook.Name Then
    
15.             Set wb = GetObject(strPath & myname)
    
16.             With wb
    
17.                 '**删除各模块内容及窗体
    
18.                 For Each m In .VBProject.VBComponents
    
19.                     If m.Type = 100 Then
    
20.                         m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
    
21.                     Else
    
22.                         .VBProject.VBComponents.Remove m
    
23.                     End If
    
24.                 Next
    
25.                 '*****************
    
26.                 Windows(.Name).Visible = True
    
27.                 '.Windows(1).Visible = True
    
28.                 '两种方法，你都可以试试。
    
29.                 .Close True
    
30.             End With
    
31.         End If
    
32.         myname = Dir
    
33.     Loop
    
34.    
    
35.     Application.EnableEvents = True
    
36.     Application.DisplayAlerts = True
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

直接改一下就成了啦。

hwc2ycy

1. Sub 删除宏()  '2003可用
   
2. 
   
3.     Dim strPath As String
   
4. 
   
5.     Dim wb As Workbook
   
6. 
   
7.     Application.ScreenUpdating = False
   
8.     Application.EnableEvents = False
   
9.     Application.DisplayAlerts = False
   
10.     On Error Resume Next
    
11. 
    
12.     strPath = ThisWorkbook.Path & Application.PathSeparator
    
13.     myname = Dir(strPath & "*.xls")
    
14. 
    
15.     Do While myname <> ""
    
16.         If myname <> ThisWorkbook.Name Then
    
17.             Set wb = GetObject(strPath & myname)
    
18.             With wb
    
19.                 '**删除各模块内容及窗体
    
20.                 For Each m In .VBProject.VBComponents
    
21.                     If m.Type = 100 Then
    
22.                         m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
    
23.                     Else
    
24.                         .VBProject.VBComponents.Remove m
    
25.                     End If
    
26.                 Next
    
27.                 '*****************
    
28.                 .Close True
    
29.             End With
    
30.         End If
    
31.         myname = Dir
    
32.     Loop
    
33.     Application.EnableEvents = True
    
34.     Application.DisplayAlerts = True
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

zjdh

1. Sub 删除宏()  '2003可用
   
2.     Application.ScreenUpdating = False
   
3.     Application.EnableEvents = False
   
4.      Application.DisplayAlerts = False
   
5.     On Error Resume Next
   
6.     MyName = Dir(ThisWorkbook.Path & "\*.xls")
   
7.     Do While MyName <> ""
   
8.         If MyName <> ThisWorkbook.Name Then
   
9.             Workbooks.Open (MyName)
   
10.             With ActiveWorkbook
    
11.                 '**删除各模块内容及窗体
    
12.                 For Each m In .VBProject.VBComponents
    
13.                     If m.Type = 100 Then
    
14.                         m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
    
15.                     Else
    
16.                         .VBProject.VBComponents.Remove m
    
17.                     End If
    
18.                 Next
    
19.                 '*****************
    
20.                 .Close True
    
21.             End With
    
22.         End If
    
23.         MyName = Dir
    
24.     Loop
    
25.     Application.EnableEvents = True
    
26.     Application.DisplayAlerts = True
    
27.     Application.ScreenUpdating = True
    
28. End Sub

复制代码

小雨饰品

zjdh 发表于 2013-11-8 16:59

谢谢老师的帮助，但不知什么原因，我试了一下（我勾选了信任对于'Visual BASIC"的访问）没能将同文件 夹中代码去除。

小雨饰品

hwc2ycy 发表于 2013-11-8 16:52

里面的代码是删除了，但运行后工作表被隐藏了起来，烦请老师抽空再修改一下。谢谢啦！

hwc2ycy

1. Sub 删除宏()  '2003可用
   
2. 
   
3.     Dim strPath As String
   
4.     Dim wb As Workbook
   
5. 
   
6.     On Error Resume Next
   
7.     Application.ScreenUpdating = False
   
8.     Application.EnableEvents = False
   
9.     Application.DisplayAlerts = False
   
10.     strPath = ThisWorkbook.Path & Application.PathSeparator
    
11.     myname = Dir(strPath & "*.xls")
    
12.    
    
13.     Do While myname <> ""
    
14.         If myname <> ThisWorkbook.Name Then
    
15.             Set wb = GetObject(strPath & myname)
    
16.             With wb
    
17.                 '**删除各模块内容及窗体
    
18.                 For Each m In .VBProject.VBComponents
    
19.                     If m.Type = 100 Then
    
20.                         m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
    
21.                     Else
    
22.                         .VBProject.VBComponents.Remove m
    
23.                     End If
    
24.                 Next
    
25.                 '*****************
    
26.                 Windows(.Name).Visible = True
    
27.                 '.Windows(1).Visible = True
    
28.                 '两种方法，你都可以试试。
    
29.                 .Close True
    
30.             End With
    
31.         End If
    
32.         myname = Dir
    
33.     Loop
    
34.    
    
35.     Application.EnableEvents = True
    
36.     Application.DisplayAlerts = True
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

zjdh

小雨饰品 发表于 2013-11-9 15:09
谢谢老师的帮助，但不知什么原因，我试了一下（我勾选了信任对于'Visual BASIC"的访问）没能将同文件 夹中 ...

4楼的宏我可是在2003测试过的，没问题啊！

小雨饰品

zjdh 发表于 2013-11-9 17:52
4楼的宏我可是测试过的，没问题啊！

谢谢您的帮助。我也感到很奇怪 ，原来你发的那个可选择文件 夹再删除代码的那个在我家里电脑上竟然也不能运行（以前我在办公室电脑上很好用的）。后天上班我再用办公室电脑测试 一下。再次感谢老师的帮忙。

小雨饰品

hwc2ycy 发表于 2013-11-8 16:48
直接改一下就成了啦。

这个代码运行很好。非常感谢hwc2ycy大师的多次出手相助。