批量删除宏模块窗体类模块模板

f8b1987 · 发表于 2019-7-5 11:12

本帖最后由 f8b1987 于 2019-7-24 11:22 编辑

由于工作需要，经常给工作簿设置一些VBA代码，并保存在不同月份的工作簿中。

突然觉得，哪天把表格发给其他人时，老是有宏启用提示，对不用VBA且有强迫症的人是个烦恼的提示。

于是我在度娘搜索+EH/EP论坛的资料，通过加工整理出批量删除宏模块、类模块、窗体的代码，分享给大家。
该模板可以批量删除宏模块、类模块、窗体的代码，包含在sheet和thiswokbook里的代码也删除。

使用前需对Excel进行设置：文件——选项——信任中心——信任中心设置——宏设置——勾选【信任对VBA对象模型的访问】，再运行VBA

由于代码是复制、修改为主，一些多余的定义、无关语句并未做删除处理。盼各位对代码加以修改，让代码更简洁、高效。

特别鸣谢以下帖子：
我学【喜迎2015立春】遍历文件夹(含子文件夹)方法 ABC http://club.excelhome.net/thread-1185089-1-1.html?referrer=

http://club.excelhome.net/forum.php?mod=viewthread&tid=864766

http://club.excelhome.net/thread-1023302-1-1.html

http://club.excelhome.net/thread-1123734-1-1.html

原代码文件夹中有非Excel文件时会崩溃，现已更新代码解决。

f8b1987 · 发表于 2019-7-24 11:16

20190724已更新，补充了指定删除类型为窗体的代码，该段代码已注释，请自行解除注释及修改。

If m.Type = 3 Then ''模块的值为1，类模块为2，窗体type值为3，Sheet及Thisworkbook为100
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If
<p> </p>

复制代码

f8b1987 · 发表于 2019-7-5 11:13

Sub 删除模块等()
'------------------单个文件夹，不含子文件夹
Dim VBP As Object, vbc As Object, shp As Shape, sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
Application.AskToUpdateLinks = False '不更新链接
Application.DisplayAlerts = False '不提示窗口
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
Path = .SelectedItems(1)
File = Dir(Path & "\*.xls*")
' Application.EnableEvents = False
' Application.Calculation = xlCalculationManual
Do Until LenB(File) = 0
Set Wb = Workbooks.Open(Filename:=Path & "" & File)
For Each m In Wb.VBProject.VBComponents
If m.Name Like "*" Then
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If
Next m
Wb.Close savechanges:=True '关闭
File = Dir
Loop
End If
End With
Application.ScreenUpdating = True '恢复屏幕刷新
Application.AskToUpdateLinks = True '更新链接
Application.DisplayAlerts = True '提示窗口
Application.Calculation = xlCalculationAutomatic '恢复自动重算
MsgBox "已完成"
End Sub

复制代码

f8b1987 · 发表于 2019-7-5 11:15

本帖最后由 f8b1987 于 2019-7-5 22:34 编辑

Sub ListFilesTest()
'-----------------文件夹内含有子文件夹操作
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
Application.AskToUpdateLinks = False '不更新链接
Application.DisplayAlerts = False '不提示窗口
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
End With
If Right(myPath, 1) <> "" Then myPath = myPath & ""
' [a:b] = "" '清空A列
Call ListAllFso(myPath) '调用FSO遍历子文件夹的递归过程
Application.EnableEvents = True
Application.ScreenUpdating = True '恢复屏幕刷新
Application.AskToUpdateLinks = True '更新链接
Application.DisplayAlerts = True '提示窗口
Application.Calculation = xlCalculationAutomatic '恢复自动重算
MsgBox "已完成"
End Sub
Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
On Error Resume Next
Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
'用FSO方法得到当前路径的文件夹对象实例注意这里的【当前路径myPath是个递归变量】
ad = fld.Path
For Each f In fld.Files '遍历当前文件夹内所有【文件.Files】
If f.Name Like "*.xls*" Then
ddname = f.Name
' [a65536].End(3).Offset(1) = f.Name '在A列逐个列出文件名
Set Wb = Workbooks.Open(Filename:=ad & "" & f.Name) '打开文件操作
For Each m In Wb.VBProject.VBComponents
If m.Name Like "*" Then
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If
Next m
Wb.Close savechanges:=True '保存并关闭
End If
Next f
For Each fd In fld.SubFolders '遍历当前文件夹内所有【子文件夹.SubFolders】
ad2 = fd.Path
na2 = fd.Name
' [a65536].End(3).Offset(1) = " " & fd.Name & "" '在A列逐个列出子文件夹名
Call ListAllFso(fd.Path) '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
'注意重点在这里：继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
Next fd
End Function

复制代码

huazai688 · 发表于 2019-7-23 14:45

f8b1987 发表于 2019-7-5 11:15

老师好！如果想保留窗体，代码要如何修改，请赐教，谢谢！

f8b1987 · 发表于 2019-7-24 10:12

本帖最后由 f8b1987 于 2019-7-24 11:10 编辑

huazai688 发表于 2019-7-23 14:45
老师好！如果想保留窗体，代码要如何修改，请赐教，谢谢！

把If m.Name Like "*" Then这一段改一下，

If m.Type = 3 Then ''模块的值为1，类模块为2，窗体type值为3，Sheet及Thisworkbook为100
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If

复制代码

huazai688 · 发表于 2019-7-24 10:19

好的，谢谢老师指点！！！

f8b1987 · 发表于 2019-7-24 11:06

本帖最后由 f8b1987 于 2019-7-24 11:10 编辑

huazai688 发表于 2019-7-24 10:19
好的，谢谢老师指点！！！

If m.Type = 3 Then ''模块的值为1，类模块为2，窗体type值为3，Sheet及Thisworkbook为100
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If

复制代码

第一次回复的代码有误，已修改，请留意。

f8b1987 · 发表于 2019-7-24 11:13

本帖最后由 f8b1987 于 2019-7-29 12:53 编辑

Sub 删除模块等()
'------------------单个文件夹，不含子文件夹
Dim VBP As Object, vbc As Object, shp As Shape, sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False '冻结屏幕，以防屏幕抖动
Application.AskToUpdateLinks = False '不更新链接
Application.DisplayAlerts = False '不提示窗口
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
Path = .SelectedItems(1)
File = Dir(Path & "\*.xls*")
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Do Until LenB(File) = 0
Set Wb = Workbooks.Open(Filename:=Path & "" & File)
' For Each sht In Wb.Sheets
' If sht.Type = xlExcel4MacroSheet Or sht.Name Like "Macro*" Then '判断是否宏表4.0
' sht.Visible = True
' sht.Delete
' End If
' Next sht
For Each m In Wb.VBProject.VBComponents
If m.Name Like "*" Then
m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
Wb.VBProject.VBComponents.Remove m
End If
' '===========================以下一段指定删除窗体、模块、类模块、Excel对象
' If m.Type = 3 Then ''模块的值为1，类模块为2，窗体type值为3，Sheet及Thisworkbook为100
' m.CodeModule.DeleteLines 1, m.CodeModule.CountOfLines
' Wb.VBProject.VBComponents.Remove m
' End If
' '============================================
Next m
Wb.Close savechanges:=True '关闭
File = Dir
Loop
End If
End With
Application.ScreenUpdating = True '恢复屏幕刷新
Application.AskToUpdateLinks = True '更新链接
Application.DisplayAlerts = True '提示窗口
Application.Calculation = xlCalculationAutomatic '恢复自动重算

复制代码

方便大家针对性删除窗体、模块、类模块等，重新添加代码判断对象类型，判断部分已注释，请自行解除注释。

huazai688 · 发表于 2019-7-24 14:34

f8b1987 发表于 2019-7-24 11:06
第一次回复的代码有误，已修改，请留意。

收悉，谢谢老师巨献！

		自动登录	找回密码
密码			免费注册

[分享] 批量删除宏模块窗体类模块模板

评分

评分