I'm trying to change event procedure s for multiple workbooks?

Viewed 76

Please help as I stuck in error saying "object variable or with block variable not set. Error #91 It stucked in wb.close line Please help as need to change the event procedure for multiple workbooks Any idea

    Sub CopyCode()

  Dim wb As Workbook

  Dim strInput
  Dim VBP As Object, VBC As Object, CM As Object
  Dim strpath As String, strCurrentFile As String
  
 
  strpath = "C:\Users\Basem Lap\Desktop\test\"
  strCurrentFile = Dir(strpath & "*.xls"*)
   
  

  
  
  
  Do While strCurrentFile <> ""
    Set wb = Workbooks.Open(strpath & strCurrentFile)
    Set VBP = wb.VBProject
    Set VBC = VBP.VBComponents(wb.CodeName)
    Set CM = VBC.CodeModule
    
    
    Application.DisplayAlerts = False
    
    
    Application.DisplayAlerts = False
    
    With wb.VBProject.VBComponents("ThisWorkbook").CodeModule
     .ReplaceLine 1, "Private Sub Workbook_BeforeClose(Cancel As Boolean)" 
       
    End With
    
    
    
    
    wb.Close savechanges:=True
    Application.DisplayAlerts = False
    
    Set wb = Nothing
    strCurrentFile = Dir
  Loop
  
  MsgBox "Done"
End Sub


2 Answers

Please, change:

strCurrentFile = Dir(strpath & "*.xls"*)

with:

strCurrentFile = Dir(strpath & "*.xls*")

Wild character must be inside the string.

But I cannot understand how your code could pass over this. The error should (firstly) be raised on the above mentioned line...

Please, try adding this code line immediately after the line in discussion:

Debug.Print strCurrentFile: Stop

What does it return when the code stops? Is it a real workbook full name?

I would recommend that, when trying to modify something in a code module, to add a reference to "Microsoft Visual Basic for Applications Extensibility xx" library and appropriately declare the used variables. You will benefit of the intellisense suggestions, which may help a lot.

Edited:

If the code line to be replaced is the first one, your existing code should replace it with what you want. If it is not, please use the next code which will firstly search for the code to be replaces string, and make the replacement there where it is:

Function ReplaceCodeLine(wb As Workbook, strModule As String, strSearch As String, strReplace As String) As Boolean
 Dim VBProj As Object, VBComp As Object, CodeMod As Object
 Dim startL As Long, endL As Long
 Dim strCLine As String, boolFound As Boolean

    Set VBProj = wb.VBProject
    Set VBComp = VBProj.VBComponents(strModule)
    Set CodeMod = VBComp.CodeModule
    startL = 1
    With CodeMod
        endL = .CountOfLines
        boolFound = .Find(Target:=strSearch, StartLine:=startL, StartColumn:=1, _
              EndLine:=endL, EndColumn:=255, wholeword:=True, MatchCase:=False, _
                                                             patternsearch:=False)

        If boolFound Then
            strCLine = Replace(CodeMod.Lines(startL, 1), strSearch, _
                                     strReplace, Compare:=vbTextCompare)
            .ReplaceLine startL, strCLine
            ReplaceCodeLine = True
        Else
            ReplaceCodeLine = False
        End If
    End With
End Function

It can be called from your code by copying the above function in a standard module and replacing the next part:

With wb.VBProject.VBComponents("ThisWorkbook").CodeModule
     .ReplaceLine 1, "Private Sub Workbook_BeforeClose(Cancel As Boolean)" 
       
End With

with this one:

Dim strExist as String, strToReplace as String
strExist = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)"
strToReplace = "Private Sub Workbook_BeforeClose(Cancel As Boolean)"
Debug.Print ReplaceCodeLine(wb, "ThisWorkbook", strExist, strToReplace)

It will return in Immediate Window True if the line to be replaced has been found and the replacement took place.

Please, test it and send some feedback.

Edited second time:

The following solution will use a workbook having a correct "ThisWorkbook" code module, which will be copied to all the workbooks in the strPathfolder. You must take care of the strCurrentFile value. It may allow .xlsx documents, which cannot be saved with VBA inside...

  1. The following solution needs a reference to 'Microsoft Visual for Applications Extensibility 5.3'. In order to add it programmatically, please copy the next code in a standard module and run it:
Sub addExtenssibilityReference()
   ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3
End Sub
  1. Your existing code should be replaced by the next one:
Sub CopyThisWorkbookCode()
'It needs a reference to 'Microsoft Visual for Applications Extensibility 5.3'.
 Dim VBProjSource As VBIDE.VBProject, VBCompSource As VBIDE.VBComponent
 Dim VBProjTarget As VBIDE.VBProject, wb As Workbook, strCode As String
 
 Set VBProjSource = ThisWorkbook.VBProject 'or another (open) workbook keeping
                                           'the ThisWorkbook code to be copyed from
 Set VBCompSource = VBProjSource.VBComponents("ThisWorkbook")
 'all ThisWorkbook module code copied as string:
 strCode = VBCompSource.CodeModule.Lines(1, VBCompSource.CodeModule.CountOfLines)

  Dim strPath As String, strCurrentFile As String
  
  strPath = "C:\Users\Basem Lap\Desktop\test\"
  strCurrentFile = Dir(strPath & "*.xls*")
    
  Application.EnableEvents = False: Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
    
  Do While strCurrentFile <> ""
    Set wb = Workbooks.Open(strPath & strCurrentFile)
    Set VBProjTarget = wb.VBProject
        
    impThisWorkbookModule VBProjTarget, strCode
    
    wb.Close savechanges:=True
    strCurrentFile = Dir
  Loop
  
  Application.EnableEvents = True: Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  
  MsgBox "Done"
End Sub

Please, take care of VBProjSource choosing. In the above code, I used the workbook keeping this code. You may use another one: Set VBProjSource = Workbooks("Model Workbook").VBProject.

  1. Copy the next function below the above code:
Function impThisWorkbookModule(VBProjT As VBIDE.VBProject, strCode As String)
  Dim VBCompTarget As VBIDE.VBComponent
        
  Set VBCompTarget = VBProjT.VBComponents("ThisWorkbook")
     
    With VBCompTarget.CodeModule
        .DeleteLines 1, .CountOfLines
        .InsertLines 1, strCode
    End With
End Function 
  1. Run CopyThisWorkbookCode Sub and send some feedback.

Change Type of Event Procedure

  • Something like this could be a solution. Hopefully the event procedures start in the first line.

The Code

Option Explicit

Sub CopyCode()

    Const ReplaceString As String = _
      "Private Sub Workbook_BeforeClose(Cancel As Boolean)"
    
    Dim wb As Workbook
    Dim VBP As Object, VBC As Object, CM As Object
    Dim strpath As String, strCurrentFile As String
   
    strpath = "C:\Users\Basem Lap\Desktop\test\"
    strCurrentFile = Dir(strpath & "*.xls*")
    
    Do While strCurrentFile <> ""
        
        Set wb = Workbooks.Open(strpath & strCurrentFile)
        ' Debug.Print wb.FullName
        Set VBP = wb.VBProject
        Set VBC = VBP.VBComponents(wb.CodeName)
        Set CM = VBC.CodeModule
        
        Application.DisplayAlerts = False
        CM.ReplaceLine 1, ReplaceString
        wb.Close SaveChanges:=True
        Application.DisplayAlerts = False
        
        strCurrentFile = Dir
    
    Loop
    
    MsgBox "Done"

End Sub
Related