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...
- 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
- 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.
- 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
- Run
CopyThisWorkbookCode Sub and send some feedback.