エクセル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がクラッシュすると思います。また、すべてのシートには、不要な編集やフォーマットの変更を避けるために、編集可能/保護されていない選択セルしかないことにも言及する必要があります。

私はこれをもっとうまくできると思うなら、これについての助けや感謝の意を表します。

ありがとうございました！

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

OKを保護するために - 私は...解決された問題、または発見された問題、またはその両方。上記の回答がお手伝いしましたが、ありがとうございます。

worksheet_activateとworksheet_change関数に問題があったようですが、これはシートを反復処理するときに何らかの連続ループが発生している可能性があります。これは、上記の関数を呼び出す前にApplication.EnableEvents = Falseを使用するだけで解決されました。このようなシートをループするときに他の関数/サブを実行するつもりはありません。