[英]Excel VBA - Automation Error during loop
您好,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
循环中的For Each ws in currWB.Worksheets
的工作表For Each ws in currWB.Worksheets
的问题,即使当我注释掉其他循环来添加/删除名称时,它仍然会导致自动化错误 ,然后导致Excel崩溃。 我还应该提到,每个工作表都只有一个可编辑/未受保护的选定单元格,以尝试避免不必要的编辑和格式更改,这就是为什么我需要在添加/删除名称或更改单元格值之前先取消保护。
如果您觉得我可以做得更好,对此将提供任何帮助,甚至发表评论。
谢谢!
我记得有这个错误,这与我保护纸张以完成使用的方式有关-
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
保护
好的-我认为...问题已解决或已找到,或两者都有。 尽管以上答案确实对您有所帮助。
似乎问题归结于可能在worksheet_activate和worksheet_change函数中包含代码,这些代码很可能在遍历工作表时引起一些连续循环。 这可以通过在调用上面的Function之前简单地使用Application.EnableEvents = False
来解决,因为在遍历这样的工作表时,我不希望运行任何其他函数/子。
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.