vba - 如果在源 WB 中未找到，则删除目标 WB 中的 VB 组件

Question

我正在编写一个过程，以从另一个启用宏的 Excel 工作簿（源）更新一个启用宏的 Excel 工作簿（目标）中的组件。最终结果是使目标组件（工作表、用户表单、模块等）与源组件匹配。

到目前为止，我已经成功 (1) 从源中添加了在目标中找不到的组件，(2) 用较新版本替换了工作表，(3) 全局更新了所有模块、类模块和用户表单中的代码，以及 ( 4) 更新了各种工作表中的杂项单元格公式和值。

我一直在努力的地方是删除源中找不到的目标组件。我一直在尝试各种方法，并相信我已经接近但无法克服实际 VBComponents.Remove 行中的各种错误。这是我的代码：

    Sub UpdateDest()
    'Purpose:
    'Sources: (1) https://www.excel-easy.com/vba/examples/import-sheets.html
    '         (2) https://stackoverflow.com/questions/16174469/unprotect-vbDestProject-from-vb-code
    '         (3) https://stackoverflow.com/questions/18497527/copy-vba-code-from-a-sheet-in-one-workbook-to-another

    '=== Declare Variables
        Dim booCompFound As Boolean
        Dim cmSrc As CodeModule, cmDest As CodeModule
        Dim xlWBDest As Excel.Workbook, xlWSDest As Excel.Worksheet
        Dim xlWBSrc As Excel.Workbook, xlWSSrc As Excel.Worksheet
        Dim i As Integer, j As Integer
        Dim lngVBUnlocked As Long
        Dim vbDestComp As Object, vbDestComps As Object, vbDestProj As Object, vbDestMod As Object
        Dim vbSrcComp As Object, vbSrcComps As Object, vbSrcProj As Object, vbSrcMod As Object
        Dim modModule As Object
        Dim strDestName As String, strDestPath As String, strSrcName As String, strSrcPath As String
        Dim strUpdName As String, strUpdPath As String

        'On Error GoTo ErrorHandler
    '=== Initialize Variables and Prepare for Execution
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        strUpdPath = ThisWorkbook.Path & "\"

    '=== (Code execution)
        '--- Select Dest and source workbooks for the update, and remove workbook, worksheet and VBA Project protection from both
        strSrcPath = Application.GetOpenFilename(Title:="Select SOURCE workbook for the update", FileFilter:="Excel Files *.xls* (*.xls*),")
        If strSrcPath = "" Then
            MsgBox "No source workbook was selected.", vbExclamation, "Sorry!"
            Exit Sub
        Else
            Set xlWBSrc = Workbooks.Open(strSrcPath)
            UnprotectAll xlWBSrc
            'For Each xlWSSrc In xlWBSrc.Worksheets
            '    xlWSSrc.Visible = xlSheetVisible
            'Next xlWSSrc
            Set vbSrcProj = xlWBSrc.VBProject
            lngVBUnlocked = UnlockProject(vbSrcProj, "FMD090")
            Debug.Print lngVBUnlocked
            If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
                MsgBox "The source VB Project could not be unlocked.", vbExclamation, "Error!"
                Exit Sub
            Else
                Set vbSrcComps = vbSrcProj.VBComponents
            End If
        End If
        strDestPath = Application.GetOpenFilename(Title:="Select DESTINATION workbook to update", FileFilter:="Excel Files *.xls* (*.xls*),")
        If strDestPath = "" Then
            MsgBox "No destination workbook was selected.", vbExclamation, "Sorry!"
            Exit Sub
        Else
            Set xlWBDest = Workbooks.Open(strDestPath)
            UnprotectAll xlWBDest
            'For Each xlWSDest In xlWBDest.Worksheets
            '    xlWSDest.Visible = xlSheetVisible
            'Next xlWSDest
            Set vbDestProj = xlWBDest.VBProject
            lngVBUnlocked = UnlockProject(vbDestProj, "FMD090")
            Debug.Print lngVBUnlocked
            If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
                MsgBox "The destination VB Project could not be unlocked.", vbExclamation, "Error!"
                Exit Sub
            Else
                Set vbDestComps = vbDestProj.VBComponents
            End If
        End If

        '--- Add components from source that are not found in destination
        For Each vbSrcComp In vbSrcComps

            Debug.Print vbSrcComp.Name
            booCompFound = False
            For Each vbDestComp In vbDestComps

                If vbSrcComp.Name = vbDestComp.Name Then
                    booCompFound = True
                    Exit For
                End If

            Next vbDestComp
            If booCompFound = False Then
                Application.EnableEvents = False
                vbSrcComp.Export strSrcPath & vbSrcComp.Name
                vbDestComps.Import strSrcPath & vbSrcComp.Name
                Kill strSrcPath & vbSrcComp.Name
                Application.EnableEvents = True
            End If

        Next vbSrcComp

        '--- Delete components in destination that are not found in source
        Set vbDestComps = vbDestProj.VBComponents
        For i = vbDestComps.Count To 1 Step -1
        'For Each vbDestComp In vbDestComps

            booCompFound = False
            For Each vbSrcComp In vbSrcComps

                Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComps(i).Name
                If vbDestComps(i).Name = vbSrcComp.Name Then
                    booCompFound = True
                    Exit For
                End If

            Next vbSrcComp
            If booCompFound = False Then
                Application.EnableEvents = False

    '>>> PROBLEM LINE
                vbDestProj.VBComponents.Remove vbDestComps(i)
    '<<<

                Application.EnableEvents = True
            End If

        'Next vbDestComp
        Next i

        '--- Replace worksheet(s) with newer versions
        strUpdName = "Lists_WS_3_1.xlsx"
        If Dir(strUpdPath & strUpdName) <> "" Then
            Application.EnableEvents = False
            Set xlWBSrc = Workbooks.Open(strUpdPath & strUpdName)
            xlWBDest.Worksheets("Lists").Visible = xlSheetVisible
            Application.DisplayAlerts = False
            xlWBDest.Worksheets("Lists").Name = "Lists_Old"
            xlWBSrc.Worksheets("Lists").Copy After:=xlWBDest.Worksheets("FYMILES")
            xlWBDest.Worksheets("Lists_Old").Delete
            xlWBSrc.Close
            Application.EnableEvents = True
        Else
            MsgBox "The file " & strUpdName & " is missing.", vbExclamation, "File Missing!"
            Exit Sub
        End If

        '--- Globally update code in modules, class modules and user forms
        For Each vbSrcComp In vbSrcComps

            Set cmSrc = vbSrcComp.CodeModule
            Debug.Print vbSrcComp.Name
            Set cmDest = vbDestComps(vbSrcComp.Name).CodeModule
            If cmSrc.CountOfLines > 0 Then
                Application.EnableEvents = False
                cmDest.DeleteLines 1, cmDest.CountOfLines  'Delete all lines in Dest component
                cmDest.AddFromString cmSrc.Lines(1, cmSrc.CountOfLines)  'Copy all lines from source component to Dest component
                Application.EnableEvents = True
            End If

        Next vbSrcComp

        '--- Update miscellaneous cell formulas and values
        Application.EnableEvents = False
        xlWBDest.Sheets("Inventory Data and July").Range("E2").Formula = "=TEXT(Lists!$O$5, " & Chr(34) & "000" & Chr(34) & ")"
        Application.EnableEvents = True

    '=== Error Handling
    ErrorHandler:
        Application.EnableEvents = True

    '=== Release Variables and Cleanup
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True

    End Sub

问题代码大约是 '>>> 问题行之后的 2/3。这行代码在尝试删除 Sheet18 代码模块时产生运行时错误 5、无效的过程调用或参数。

在运行期间，原始的 Sheet16（列表）被删除并替换为 Excel 编号 Sheet18 的新列表工作表。经过一个周末的沉思，我相信问题源于组件命名。为了解决这个问题，代码引用了组件名称，但新工作表的 VB 属性是 (Name) = (Sheet18) 和 Name = Lists（注意括号）。

我现在尝试在每次操作后保存工作簿，而不会更改错误或发生错误的结构的哪一部分。

正如目前所写的那样，我正在向后循环目标组件集合，并在源中找不到目标中的组件时尝试删除。注释掉的原始前向循环的残余部分也不起作用。我尝试了很多变体，要么得到无效的过程调用，要么在对象中找不到属性或方法。

我花了一天时间玩这个。请看一看，帮助我看到光明！

我正在运行 Excel 2016

标签： vbaexcelmodulecomponents

Answer 1

在 @Comintern 的评论之后，我添加了测试以确保 Remove 方法仅应用于非文档模块。这是用于删除模块的重写代码块：

    '--- Delete non-document components in destination that are not found in source
    Set vbDestComps = vbDestProj.VBComponents
    For Each vbDestComp In vbDestComps

        If vbDestComp.Type >= 1 And vbDestComp.Type <= 3 Then
            booCompFound = False
            For Each vbSrcComp In vbSrcComps

                Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComp.Name; " Type: "; vbDestComp.Type
                If vbDestComp.Name = vbSrcComp.Name Then
                    booCompFound = True
                    Exit For
                End If

            Next vbSrcComp
            If booCompFound = False Then
                Application.EnableEvents = False
                vbDestProj.VBComponents.Remove vbDestComp
                Application.EnableEvents = True
            End If
        End If

    Next vbDestComp