Excel VBA - 循环期间的自动化错误

Question

大家好，StackOverflow 用户，

所以我的问题在于大量使用 VBA 来自动化和计算多个函数的工作簿。然而，特别是我编写的一个函数，它在更新主副本时更新工作簿的代码和命名范围，这只需通过单元格检查中的版本号即可完成。

Function updateCheck(cVer As Double) As Double
Dim currWB As Workbook, isWB As Workbook, iSht As Worksheet, ver As Range, wbName As String, path As String
Dim isCode As CodeModule, wbCode As CodeModule, wbMod As CodeModule, isMod As CodeModule, isNames As New Collection, isVal As New Collection
Dim tmp As Name, nm As Name, ws As Worksheet, tn As Range, verNum As Double, nStr As String, raf As Boolean, tStr As String

path = "Q:\JWILDE\": wbName = "testsheet.xlsm"
Set currWB = ThisWorkbook

With currWB
    .Activate
    Set wbCode = .VBProject.VBComponents("ThisWorkbook").CodeModule
    Set iSht = .Sheets(1)
End With

If Dir(path & wbName) <> "" And Not currWB.path & "\" Like path Then
    Set isWB = Workbooks.Open(path & wbName, ReadOnly:=True)
    isWB.Activate
    verNum = isWB.Names("VerNum").RefersToRange
Else
    updateCheck = cVer
    Exit Function
End If

If cVer < verNum Then
    Debug.Print "...update required, current version: " & verNum
    With isWB
        With .VBProject
            Set isMod = .VBComponents("ISCode").CodeModule
            Set isCode = .VBComponents("ThisWorkbook").CodeModule
        End With

        '--- COMPILES LIST OF NAMES FROM STANDARD SHEET ---
        For Each nm In .Names
            nVal = "=SHT!"
            key = getNRVal(nm.Name, 3)
            nStr = getNRVal(nm.RefersToLocal, 3)
            Debug.Print "Sheet set to: " & getNRVal(nm.Name, 1)
            .Sheets(getNRVal(nm.Name, 1)).Unprotect Password:="jwedit"
            Set tn = .Sheets(getNRVal(nm.Name, 1)).Range(nStr) 'Untested...
            On Error Resume Next
            tStr = isNames(key)
            If tStr <> "" Then
                tStr = ""
            Else
                If nm.Parent.Name = .Name Then
                    Set tn = .Sheets(1).Range(nStr)
                    nVal = "=WB!"
                    isVal.Add tn, key
                    Debug.Print "isVal > " & isVal(key).Name
                End If
                isNames.Add key & nVal & nStr, key
                Debug.Print "...added: " & isNames.Item(key)
            End If
        Next nm
    End With

    If isCode.CountOfLines > 0 And isMod.CountOfLines > 0 Then
        With currWB.VBProject
            Set wbCode = .VBComponents("ISCode").CodeModule
            wbCode.DeleteLines 1, wbCode.CountOfLines
            wbCode.AddFromString isMod.Lines(1, isMod.CountOfLines)

            Set wbCode = .VBComponents("ThisWorkBook").CodeModule
            wbCode.DeleteLines 1, wbCode.CountOfLines
            wbCode.AddFromString isCode.Lines(1, isCode.CountOfLines)
            updateCheck = verNum
        End With
    Else
        Debug.Print "Error. Unable to get updated code."
        updateCheck = cVer
    End If

    isWB.Close SaveChanges:=False
    currWB.Activate

    On Error Resume Next
    Dim wbStr As String: wbStr = isWB.Name

    If wbStr <> "" Then
        Debug.Print "WARNING: " & wbStr & " is still open!"
    Else: Debug.Print "Successfully closed isWB."
    End If

    '--- CHECKS THROUGH EACH SHEET FROM CURRENT WB ---
    For Each ws In currWB.Worksheets
        ws.Unprotect Password:="jwedit"
       '--- CHECK TO REMOVE INVALID OR INCORRECT NAMES ---
        For Each nm In ws.Names
            raf = False
            key = getNRVal(nm.Name, 3) '--> SHEET!NAME > NAME
            nStr = getNRVal(nm.RefersTo, 3) '---> SHEET!REF > REF
            tStr = isNames(key) 'Could change this to: getNRVal(isNames(key),3) to return just REF or nothing.
            Debug.Print "...[" & key & "]..."
            If tStr <> "" Then 'MATCH FOUND...
                Set tn = ws.Range(getNRVal(tStr, 3)) 'Should be the CORRECT RefTo from isNames.
                '--- NAME ON WRONG SHEET ---
                If ws.Index > 1 And getNRVal(tStr, 2) Like "WB" Then
                    Debug.Print " > REMOVE: [" & key & "] does not belong on " & ws.Name
                    nm.Delete
                '--- NAME CORRECT BUT REFTO ISNT ---
                ElseIf Not nStr Like getNRVal(tStr, 3) Then
                    Debug.Print " > INCORRECT: REF (" & nStr & ") of [" & key & "] should be (" & tn.Address & ")."
                    nm.RefersTo = tn
                End If
                tStr = ""
            Else '--- NO MATCH FOUND / INVALID NAME ---
                Debug.Print " > REMOVE: [" & key & "] is invalid."
                raf = True
            End If
            If raf = True Then
                Set tn = ws.Range(nStr)
                tn.ClearContents
                nm.Delete
            End If
        Next nm

       '--- CHECKING FOR NAMES TO ADD ---
        For n = 1 To isNames.Count
            raf = False
            key = getNRVal(isNames(n), 1)   '--> NAME
            nStr = getNRVal(isNames(n), 3)  '--> REF
            nVal = getNRVal(isNames(n), 2)  '--> SHT/WB
            Debug.Print "Looking for [" & key & "] on " & ws.Name

            If ws.Index = 1 And nVal Like "WB" Then
                tStr = currWB.Names(key, RefersTo:=nStr)
                If tStr <> "" Then
                    tStr = ""
                Else: raf = True
                End If
            ElseIf ws.Index > 1 And nVal Like "SHT" Then
                tStr = ws.Names(key, RefersTo:=nStr)
                If tStr <> "" Then
                    tStr = ""
                Else: raf = True
                End If
            End If
            If raf = True Then
                Set tn = ws.Range(nStr)
                ws.Names.Add key, tn
                tStr = isVal(key).Name
                If tStr <> "" Then
                    ws.Names.Add key, tn
                    tn.Value = isVal(key).Value
                End If
                Debug.Print " > ADDED: [" & ws.Names(key).Name & "] with REF [" & ws.Names(key).RefersToLocal & "] on " & ws.Name
            End If
        Next n
        ws.Protect Password:="jwedit", UserInterfaceOnly:=True, AllowFormattingCells:=False
    Next ws

    Debug.Print " --- DONE CHECKING NAMES --- "
    iSht.Activate
    updateCheck = verNum
    isWB.Close SaveChanges:=False
Else
    Debug.Print "No update needed."
    updateCheck = verNum
End If    
End Function

尽我所能使其全部可读，如果有点混乱，请见谅。我想我已经缩小了与保护/取消保护 For Each ws in currWB.Worksheets 循环中的工作表有关的问题，因为即使我注释掉其他循环以添加/删除名称，它仍然会导致 自动化错误然后 Excel 崩溃。我还应该提到，每张工作表只有一个可编辑/不受保护的选定单元格，以避免不必要的编辑和格式更改，这就是为什么我需要在添加/删除名称或更改单元格值之前取消保护。

如果您觉得我可以做得更好，我们将不胜感激，甚至是 cmets。

谢谢！

Answer 1

我记得有这个错误，这与我如何保护纸张以进行我使用的饰面有关 -

    For Each ws In ActiveWorkbook.Worksheets
        If ws.ProtectContents = True Then
            ws.Unprotect "password"
        End If
    Next ws

还有这个

    For Each ws In ActiveWorkbook.Worksheets
        ws.Protect "password", DrawingObjects:=True, Contents:=True, _
                    AllowSorting:=True, AllowFiltering:=True
    Next ws

保护

Answer 2

好的-我认为...问题已解决或已找到或两者兼而有之。尽管上面的答案确实对您有所帮助。

似乎问题归结为可能在 worksheet_activate 和 worksheet_change 函数中有代码，这很可能在遍历工作表时导致一些连续循环。在调用上述函数之前，只需使用 Application.EnableEvents = False 即可解决此问题，因为我不打算在循环这样的工作表时运行任何其他函数/子程序。