Excel VBA - Automatisierung Fehler bei der Schleife

Question

Hallo dort Kerl Stackoverflow Benutzer,

Also mein Problem mit einer Arbeitsmappe ist, die VBA stark verwendet zu automatisieren und mehrere Funktionen zu berechnen. Das eine ist jedoch eine Funktion, die ich geschrieben habe und die den Code und die benannten Bereiche der Arbeitsmappe aktualisiert, wenn die Masterkopie aktualisiert wird, was einfach durch eine Versionsnummer in einer Zellenprüfung geschieht.

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 

Habe mein Bestes, um alles lesbar zu machen, und tut mir leid, wenn es ein bisschen chaotisch ist. Ich denke, ich habe das Problem mit Schutz/Schutz der Blätter innerhalb der Schleife eingegrenzt, als wenn auch wenn ich die anderen Schleifen zum Hinzufügen/Entfernen von Namen auskommentieren noch verursacht Automation Error und dann stürzt Excel ab. Ich sollte auch erwähnen, dass jedes Blatt nur ausgewählte Zellen hat, die editierbar/ungeschützt sind, um unerwünschte Bearbeitung und Formatänderungen zu vermeiden, weshalb ich den Schutz aufheben muss, bevor ich Namen hinzufüge/lösche oder Zellwerte ändere.

Irgendwelche Hilfe zu diesem würde geschätzt werden, oder sogar Kommentare, wenn Sie glauben, dass ich das besser machen könnte.

Vielen Dank!

Answer 1

Ich erinnere mich, diesen Fehler mit und es war zu tun, wie ich das Blatt für ein Finish zu schützen habe ich -

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

und diese

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

Answer 2

OK zu schützen - Ich denke ... Problem gelöst oder gefunden oder beides. Obwohl die Antwort oben half, danke.

scheint das Problem war bis auf möglicherweise Code in der Worksheet_Activate und Worksheet_Change Funktion hat, die auch eine gewisse kontinuierliche Schleife verursacht haben können, wenn sie durch die Blätter iteriert. Dies wurde einfach gelöst, indem Application.EnableEvents = False verwendet wurde, bevor die obige Funktion aufgerufen wurde, da ich nicht beabsichtige, andere Funktionen/Subs auszuführen, wenn solche Blätter durchlaufen werden.