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

Question

Hello there fellow StackOverflow users,

So my issue is with a workbook that heavily uses VBA to automate and calculate several functions. However the one in particular is a function I wrote that updates the code and named ranges of the workbook when the master copy is updated, which is done simply by a version number in a cell check.

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

Did my best to make it all readable, and sorry if its a bit messy. I think I have narrowed down the problem to do with protecting/unprotecting the sheets within the For Each ws in currWB.Worksheets loop as when even when I comment out the other loops for adding/removing names it still causes an Automation Error and then Excel crashes. I should also mention that every sheet only has a select cells that are editable/unprotected to try and avoid unwanted editing and format changing, which is why I need to unprotect before adding/removing names or changing cell values it seems.

Any help on this would be appreciated, or even comments if you feel I could do this any better.

Thank you!

Answer 1

I remember having this error and it was to do with how I was protecting the sheet for a finish I used -

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

and this

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

to protect

Answer 2

OK - I think...problem solved or found or both. Although the answer above did help thank you.

Seems the problem was down to possibly having code in the worksheet_activate and worksheet_change function, which may well have caused some continuous loop when iterating through the sheets. This was resolved simply by using Application.EnableEvents = False before the Function above is called as I don't intend any other functions/subs to be run when looping through sheets like this.