Question

我有+500个带有宏的Excel文件（* .xls），都位于同一个文件夹中。
我想从这些文件中删除所有宏。从所有文件中逐个手动删除宏将花费太多时间。

是否可以在单独的excel文件中创建一个新宏，该文件将从这些已关闭的文件中删除所有宏？

感谢您的提前指导。

Answer 1

我已经围绕宏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

Answer 2

鉴于你无法让Tony的代码工作，试试这个版本：

将“C：\ temp”更改为您选择的路径

所有 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

从多个已关闭的文件中删除excel宏

2 个答案: