如何删除清除指定文件夹中所有工作薄中的宏代码包括模块

yzyyyyyyy

指定文件夹中很多工作薄文件都有代码模块，如何批量删除，让这些工作薄，打开时不会出现宏

1. 
   
2. http://club.excelhome.net/thread-894712-1-1.htmlOption Explicit
   
3. Sub addWK2()
   
4.     Dim dic, temp, arr, tempWK, temp2
   
5.     Dim rng As Range
   
6.     Dim strArea As String
   
7.     Const BYSHNAME As String = "事业单位人员信息" '可以修改根据哪一个工作表拆分工作簿
   
8.    
   
9.     Set dic = CreateObject("scripting.dictionary") '字典
   
10.     '下面一句代码：设置上面设置的工作表中的哪一列的内容拆分工作簿
    
11.     Set rng = ThisWorkbook.Sheets(BYSHNAME).Range("b2:b" & ThisWorkbook.Sheets(BYSHNAME).Cells(65536, 2).End(xlUp).Row)
    
12.     For Each temp In rng.Cells '这个for循环实现该列的不重复值的筛选
    
13.         If Not dic.exists(temp.Value) Then
    
14.             dic.Add temp.Value, ""
    
15.         End If
    
16.     Next
    
17.    
    
18.     arr = dic.keys '返回此列不重复值的数组
    
19.    
    
20.    
    
21.     For Each temp In arr '这个For循环实现按照不重复数组的内容新建工作簿，并删除不应有的内容
    
22.         ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "" & temp & ".xls" '以当前temp的值为新工作簿的名称，备份当前工作簿
    
23.         Set tempWK = Workbooks.Open(ThisWorkbook.Path & "" & temp & ".xls") '打开以temp的值为名称的工作簿
    
24.         strArea = "" '用于储存所有需要删除的行的地址字符串
    
25.         For Each temp2 In rng.Cells '这个for循环是比较源工作簿中拆分依据的工作表中，拆分依据的那一列与当前temp值是否相同，删除不相关内容
    
26.             If temp2 <> temp Then
    
27.                 If strArea <> "" Then
    
28.                     strArea = strArea & ","
    
29.                 End If
    
30.                 strArea = strArea & tempWK.Sheets(BYSHNAME).Cells(temp2.Row, temp2.Column).EntireRow.Address
    
31.             End If
    
32.         Next
    
33. For Each m In ActiveWorkbook.VBProject.VBComponents
    
34.         If m.Name Like "模块*" Then ActiveWorkbook.VBProject.VBComponents.Remove m
    
35.     Next
    
36.         tempWK.Sheets(BYSHNAME).Range(strArea).Delete
    
37.         tempWK.Save
    
38.         tempWK.Close
    
39.     Next
    
40.    
    
41.     Set dic = Nothing
    
42.     Set rng = Nothing
    
43.     ThisWorkbook.Sheets(1).Select
    
44. End Sub
    
45. 
    

复制代码

如何应用以上宏拆分 事业单位信息采集表工作薄 ，让拆分后的工作薄不含此段代码，或者如何在另一个工作薄中运行这段代码进行拆分

yf_home

如果那些文件都没有VBA工程密码,就好办.

yzyyyyyyy

yf_home 发表于 2014-5-22 18:24
如果那些文件都没有VBA工程密码,就好办.

假定都没有VBA密码

yf_home

yzyyyyyyy 发表于 2014-5-22 18:30
假定都没有VBA密码

代码放在模块里,试试:

Sub 删除代码1()
    Dim Wb As Workbook, vbc As VBComponent, fname, i%
    Application.DisplayAlerts = False: Application.ScreenUpdating = False: Application.EnableEvents = False
    fname = Application.GetOpenFilename(filefilter:="Excel 文件, *.xl*,所有文件, *.*", MultiSelect:=True)
    If VarType(fname) = vbBoolean Then End
    For i = 1 To UBound(fname)
           If fname(i) <> ThisWorkbook.FullName Then
            If Len(Dir(Left(fname(i), InStrRev(fname(i), ".")) & "bak")) = 0 Then
                FileCopy fname(i), Left(fname(i), InStrRev(fname(i), ".")) & "bak"
            End If
            Set Wb = Workbooks.Open(fname(i))
            With Wb
                For Each vbc In .VBProject.VBComponents
                    Select Case vbc.Type
                    Case 1, 2, 3
                        With Application.VBE.ActiveVBProject.VBComponents
                            .Remove .Item(vbc.Name) '删除模块、类模块、窗体
                        End With
                    Case Else
                        vbc.CodeModule.DeleteLines 1, vbc.CodeModule.CountOfLines '删除工作表或Thisworkbook代码区代码
                    End Select
                Next
                .Save
                .Close False
            End With
            Set Wb = Nothing
            Set vbc = Nothing
        End If
    Next i
    Application.DisplayAlerts = True: Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub



....

ycsgtzn

Dim Wb As Workbook, vbc As VBComponent, fname, i%
执行这一行就报错

yxqyxq

如只删除文件夹内指定文件的宏代码呢

djyang

yf_home 发表于 2014-5-22 19:51
代码放在模块里,试试:

Sub 删除代码1()

如果密码是111111，如何改