excel - 我正在尝试更改多个工作簿的事件过程？

Question

请帮忙，因为我说错了
“未设置对象变量或 block 变量。
错误 #91
它卡在 wb.close 行
请根据需要帮助更改多个工作簿的事件过程
任何想法

    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

Answer 1

请更换:

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

和:

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

通配符必须在字符串内。
但我无法理解您的代码如何通过它。错误应该(首先)在上述行上提出......
请尝试在讨论行之后立即添加此代码行:

Debug.Print strCurrentFile: Stop

代码停止时返回什么？是真正的工作簿全名吗？
我建议，在尝试修改代码模块中的某些内容时，添加对“Microsoft Visual Basic for Applications Extensibility xx”库的引用并适本地声明使用的变量。您将受益于智能感知建议，这可能会有很大帮助。
已编辑:
如果要替换的代码行是第一个，您现有的代码应该用您想要的替换它。如果不是，请使用下一个代码，它将首先搜索要替换字符串的代码，并在那里进行替换:

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

可以通过在标准模块中复制上述函数并替换下一部分来从您的代码中调用它:

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

有了这个:

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)

它将返回 Immediate Window True如果已找到要更换的线路并进行了更换。
请测试它并发送一些反馈。
第二次编辑 :
以下解决方案将使用具有 的工作簿正确 “ThisWorkbook”代码模块，将复制到strPath中的所有工作簿中文件夹。您必须照顾 strCurrentFile值(value)。它可能允许 .xlsx 文件，这些文件不能用 VBA 保存在里面......

以下解决方案需要引用“Microsoft Visual for Applications Extensibility 5.3”。为了以编程方式添加它，请复制标准模块中的下一个代码并运行它:

Sub addExtenssibilityReference()
   ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3
End Sub

您现有的代码应替换为下一个:

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

请照顾VBProjSource选择。在上面的代码中，我使用了保留此代码的工作簿。您可以使用另一个:Set VBProjSource = Workbooks("Model Workbook").VBProject .

复制上面代码下面的下一个函数:

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 

运行CopyThisWorkbookCode Sub并发送一些反馈。