從多個關閉的文件中刪除excel宏

Question

• 我有+500 Excel文件（* .xls）有宏，都位於同一個文件夾中。
• 我想從這些文件中刪除所有的宏。從所有文件中逐個手動刪除宏將花費太多時間。

是否有可能在一個單獨的excel文件中創建一個新的宏，它將從這些關閉的文件中刪除所有的宏？

感謝您提前給予指導。

Answer 1

鑑於你不可能得到託尼的代碼工作試試這個版本：

1. 更改 「C：\ TEMP」 爲您選擇

2. 所有XLS的路徑文件將被打開，保存爲「orginalfilename_no_code」。XLSX」和之前的版本將被刪除

   Sub CullCode() 
   Dim StrFile As String 
   Dim strPath As String 
   
   Dim WB As Workbook 
   strPath = "c:\temp\" 
   StrFile = Dir(strPath & "*.xls*") 
   
   With Application 
   .DisplayAlerts = False 
   .ScreenUpdating = False 
   .EnableEvents = False 
   End With 
   
   Do While Len(StrFile) > 0 
       Set WB = Workbooks.Open(strPath & StrFile) 
       WB.SaveAs strPath & StrFile & "_no_code.xlsx", 51 
       WB.Close False 
       Kill strPath & StrFile 
       StrFile = Dir 
   Loop  
   
   With Application 
   .DisplayAlerts = True 
   .ScreenUpdating = True 
   .EnableEvents = True 
   End With 
   
   End Sub 
   

Answer 2

我已經編寫了宏程序ListComponentsSingleWbk以滿足您的要求。我已經用各種工作簿進行了測試，我相信它們提供了您所尋求的功能。

ListComponentsCtrl和DeleteLinesCtrl包含語句Path = ...。您需要修改這些語句以匹配文件夾的路徑。

我使用宏ListComponentsSingleWbk來提供我正在開發的宏的每日備份。我編碼爲ListComponentsCtrl，以便爲文件夾中的每個XLS文件調用ListComponentsSingleWbk。

我建議你在做任何事情之前運行ListComponentsCtrl。它將創建一個名稱爲「BkUp yymmdd hhmm.txt」的文件，其中「yymmdd hhmm」表示當前的日期和時間。運行後，「BkUp yymmdd hhmm.txt」將包含：

• 它找到的每個工作簿的名稱。
• 工作簿中可能包含代碼的每個組件的名稱。
• 如果組件中存在代碼，則爲該代碼的列表。

運行ListComponentsCtrl將確保你有一個完整的備份，如果你在你已經從錯誤的工作簿中刪除宏一個月的時間內發現。

DeleteCodeCtrl對文件夾中的每個XLS文件調用DeleteCodeSingleWbk。

DeleteCodeSingleWbk：

• 刪除從工作簿的所有標準和類模塊。
• 清除工作表代碼模塊中的任何代碼。
• 清除ThisWorkbook的代碼模塊中的任何代碼。

---

Option Explicit 

' This module was built from information scattered across many sites. The 
' most useful were: 
' http://vbadud.blogspot.co.uk/2007/05/insert-procedure-to-module-using.html 
' http://support.microsoft.com/kb/282830 
' http://msdn.microsoft.com/en-us/library/aa443716(v=vs.60).aspx 
' http://www.ozgrid.com/forum/showthread.php?t=32709 

' This module needs a reference to: 
'     "Microsoft Visual Basic for Applications Extensibility n.n" 

' The security system will probably prevent access to VBComponents unless you: 
' For Excel 2003, from Excel (not VB Editor) 
'  Click Tools 
'  Click Macro 
'  Click Security 
'  Click Trusted Publishers 
'  Tick Trust access to Visual Basic Project 
' For other versions of Excel search for "programmatic access to Visual Basic project not trusted" 

Sub DeleteCodeCtrl() 

    Dim FileObj As Object 
    Dim FileSysObj As Object 
    Dim FolderObj As Object 
    Dim Path As String 

    Application.ScreenUpdating = False 
    Application.EnableEvents = False 

    ' ### Change to directory containing your Excel workbooks 
    ' Note: trailing "\" is assumed by later code 
    Path = ThisWorkbook.Path & "\TestFiles\" 

    Set FileSysObj = CreateObject("Scripting.FileSystemObject") 

    Set FolderObj = FileSysObj.GetFolder(Path) 

    For Each FileObj In FolderObj.Files 
    If LCase(Right(FileObj.Name, 4)) = ".xls" Then 
     Call DeleteCodeSingleWbk(Path & FileObj.Name) 
    End If 
    Next 

    Application.ScreenUpdating = True 
    Application.EnableEvents = True 

End Sub 
Sub DeleteCodeSingleWbk(ByVal WbkName As String) 

    Dim CodeLineCrnt As Long 
    Dim InxC As Long 
    Dim NumCodeLines As Long 
    Dim VBC As VBComponent 
    Dim VBCType As Long 
    Dim VBP As VBProject 
    Dim VBMod As CodeModule 
    Dim Wbk As Workbook 

    Err.Clear 
    ' Switch off normal error handling in case attempt to open workbook fails 
    On Error Resume Next 
    ' Second parameter = False means links will not be updated since not interested in data 
    ' Third parameter = False mean open for updating 
    Set Wbk = Workbooks.Open(WbkName, False, False) 
    ' Restore normal error handling. 
    On Error GoTo 0 
    If Err.Number <> 0 Then 
    On Error Resume Next 
    ' In case partially open 
    Wbk.Close SaveChanges:=False 
    On Error GoTo 0 
    Else 

    Set VBP = Wbk.VBProject 
    ' Process components in reverse sequence because deleting a component 
    ' will change the index numbers of components below it. 
    For Each VBC In VBP.VBComponents 
     VBCType = VBC.Type 
     If VBCType = vbext_ct_StdModule Or VBCType = vbext_ct_ClassModule Then 
     ' Component is a module and can be removed 
     VBP.VBComponents.Remove VBC 
     ElseIf VBCType = vbext_ct_Document Then 
     ' Component can have a code module which can be cleared 
     Set VBMod = VBC.CodeModule 
     NumCodeLines = VBMod.CountOfLines 
     If NumCodeLines > 0 Then 
      Call VBMod.DeleteLines(1, NumCodeLines) 
     End If 
     End If 
    Next 

    Wbk.Close SaveChanges:=True 
    End If 

End Sub 
Sub ListComponentsCtrl() 

    Dim BkUpFileObj As Object 
    Dim FileObj As Object 
    Dim FileSysObj As Object 
    Dim FolderObj As Object 
    Dim Path As String 

    Application.ScreenUpdating = False 
    Application.EnableEvents = False 

    ' ### Change to directory containing your Excel workbooks 
    ' Note: trailing "\" is assumed by later code 
    Path = ThisWorkbook.Path & "\TestFiles\" 

    Set FileSysObj = CreateObject("Scripting.FileSystemObject") 

    Set FolderObj = FileSysObj.GetFolder(Path) 

    ' Second parameter = False means existing file will not be overwritten 
    ' Third parameter = False means ASCII file will be created. 
    Set BkUpFileObj = FileSysObj.CreateTextFile(Path & "BkUp " & Format(Now(), "yymmyy hhmm") & ".txt", _ 
        False, False) 

    For Each FileObj In FolderObj.Files 
    If LCase(Right(FileObj.Name, 4)) = ".xls" Then 
     Call ListComponentsSingleWbk(Path & FileObj.Name, BkUpFileObj) 
    End If 
    Next 

    BkUpFileObj.Close 

    Application.ScreenUpdating = True 
    Application.EnableEvents = True 

End Sub 
Sub ListComponentsSingleWbk(ByVal WbkName As String, ByRef BkUpFileObj As Object) 

    Dim CodeLineCrnt As Long 
    Dim InxC As Long 
    Dim NumCodeLines As Long 
    Dim VBC As VBComponent 
    Dim VBCType As Long 
    Dim VBP As VBProject 
    Dim VBMod As CodeModule 
    Dim Wbk As Workbook 

    Call BkUpFileObj.WriteLine("Workbook " & WbkName) 

    Err.Clear 
    ' Switch off normal error handling in case attempt to open workbook fails 
    On Error Resume Next 
    ' Second parameter = False means links will not be updated since not interested in data 
    ' Third parameter = True mean open read only 
    Set Wbk = Workbooks.Open(WbkName, False, True) 
    ' Restore normal error handling. 
    On Error GoTo 0 
    If Err.Number <> 0 Then 
    Call BkUpFileObj.WriteLine(" Unable to open workbook: " & Err.desc) 
    Else 
    Set VBP = Wbk.VBProject 
    For InxC = 1 To VBP.VBComponents.Count 
     Set VBC = VBP.VBComponents(InxC) 
     VBCType = VBC.Type 
     If VBCType = vbext_ct_StdModule Or VBCType = vbext_ct_ClassModule Or _ 
     VBCType = vbext_ct_Document Then 
     ' Component can have a code module 
     Set VBMod = VBC.CodeModule 
     NumCodeLines = VBMod.CountOfLines 
     If NumCodeLines = 0 Then 
      Call BkUpFileObj.WriteLine(" No code associated with " & _ 
            VBCTypeNumToName(VBCType) & " " & VBC.Name) 
     Else 
      Call BkUpFileObj.WriteLine(" Code within " & _ 
            VBCTypeNumToName(VBCType) & " " & VBC.Name) 
      For CodeLineCrnt = 1 To NumCodeLines 
      Call BkUpFileObj.WriteLine(" " & VBMod.Lines(CodeLineCrnt, 1)) 
      Next 
     End If 
     End If 
    Next 
    End If 

    Wbk.Close SaveChanges:=False 

End Sub 
Function VBCTypeNumToName(ByVal VBCType As Long) As String 

    Select Case VBCType 
    Case vbext_ct_StdModule     ' 1 
     VBCTypeNumToName = "Module" 
    Case vbext_ct_ClassModule    ' 2 
     VBCTypeNumToName = "Class Module" 
    Case vbext_ct_MSForm      ' 3 
     VBCTypeNumToName = "Form" 
    Case vbext_ct_ActiveXDesigner   ' 11 
     VBCTypeNumToName = "ActiveX Designer" 
    Case vbext_ct_Document     ' 100 
     VBCTypeNumToName = "Document Module" 
    End Select 

End Function