remove excel macros from multiple closed files - excel

Question

I have +500 Excel files (*.xls) having macros, all located in same folder.
I want to remove all macros from these files. Removing macros manually one by one from all files will take too much time.
Is it possible to create a new macro in a separate excel file which will remove all macros from these closed files?
Thanks for your guidance in advance.

Answer 1

I have coded routines around macro ListComponentsSingleWbk to meet your requirement. I have tested then with a variety of workbooks and I believe they provide the functionality you seek.
Both ListComponentsCtrl and DeleteLinesCtrl contain the statement Path = .... You will need to amend these statements to match the path of your folder.
I use macro ListComponentsSingleWbk to provide daily backups of the macros I am developing. I have coded ListComponentsCtrl to call ListComponentsSingleWbk for every XLS files in a folder.
I suggest you run ListComponentsCtrl before you do anything else. It will create a file with the name “BkUp yymmdd hhmm.txt” where “yymmdd hhmm” represent the current date and time. Following the run, “BkUp yymmdd hhmm.txt” will contain:
The name of every workbook it has found.
The name of every component within a workbook that might contain code.
If there is code within a component, a list of that code.
Running ListComponentsCtrl will ensure you have a complete backup if you discover in a month’s time that you have deleted macros from the wrong workbooks.
DeleteCodeCtrl calls DeleteCodeSingleWbk for every XLS files in a folder.
DeleteCodeSingleWbk:
Removes all standard and class modules from a workbook.
Clears any code from the code modules of the worksheets.
Clears any code from the code module of 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

Given you couldnt get Tony's code to work try this version:
Change "C:\temp" to the path of your choice
All xls files will be opened, saved as "orginalfilename_no_code.xlsx" and the prior version will be removed
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