удалять макросы excel из нескольких закрытых файлов

  • У меня есть +500 файлов Excel (* .xls), имеющих макросы, все они расположены в одной папке.
  • Я хочу удалить все макросы из этих файлов. Удаление макросов вручную по одному из всех файлов займет слишком много времени.

Возможно ли создать новый макрос в отдельном файле excel, который удалит все макросы из этих закрытых файлов?

Спасибо за ваше руководство заранее.

Учитывая, что вы не можете получить код Тони для работы, попробуйте эту версию:

  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 

Я запрограммировал процедуры вокруг макроса ListComponentsSingleWbk чтобы удовлетворить ваши требования. Затем я тестировал множество книг, и я считаю, что они обеспечивают функциональность, которую вы ищете.

И ListComponentsCtrl и DeleteLinesCtrl содержат инструкцию Path = ... Вам нужно будет изменить эти утверждения, чтобы они соответствовали пути вашей папки.

Я использую макрос ListComponentsSingleWbk для ежедневного резервного копирования макросов, которые я разрабатываю. Я закодировал ListComponentsCtrl для вызова ListComponentsSingleWbk для каждого файла XLS в папке.

Я предлагаю вам запустить ListComponentsCtrl прежде чем делать что-либо еще. Он создаст файл с именем «BkUp yymmdd hhmm.txt», где «yymmdd hhmm» представляет текущую дату и время. После запуска «BkUp yymmdd hhmm.txt» будет содержать:

  • Имя каждой найденной книги.
  • Имя каждого компонента в книге, которая может содержать код.
  • Если в компоненте есть код, список этого кода.

Запуск ListComponentsCtrl обеспечит полную резервную копию, если через месяц вы обнаружите, что вы удалили макросы из неправильных книг.

DeleteCodeCtrl вызывает DeleteCodeSingleWbk для каждого файла XLS в папке.

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 nn" ' 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 
Давайте будем гением компьютера.