В Excel VBA обработка книг прекращается после случайного количества книг

Question

Нам нужно запустить программу VBA для обновления более 500+ книг (удаление и изменение листа в каждой из них).

Приведенная ниже программа VBA выполняет рекурсивный обход всей книги.

ВЫПУСК

После выполнения любого из 50, 200, а иногда и 400 макрос останавливается.Нет ошибокЭто просто оставляет открытую книгу на экране.это всегда другая рабочая книга, и часто она обрабатывает нарушителя, поэтому она не связана с содержанием.

Я думал, что это может быть

GetFilesRecursive fso.GetFolder(directory), "xlsx", files, fso

, который получаетперепутал из-за обновления рабочей книги с помощью SAVE.Но я также пытался поместить вывод через SAVAS в отдельное дерево папок, и это не влияет на вещи.

Есть идеи, как отладить такую ​​проблему?

Const ProgDir = "D:\Staffing\SkillsUpdate\ProgramOfficeData" 

Sub allPrograms(directory As String)
    Dim fso As New Scripting.FileSystemObject
    Dim files As New Collection
    Dim file As Scripting.file
    Dim result As Boolean
    Dim index As Integer
    clearErrors
    GetFilesRecursive fso.GetFolder(directory), "xlsx", files, fso
    index = 1
    For Each file In files
        If file Is Nothing Then
            ' Do nothing
        Else
            result = oneProgram(file.ParentFolder.path, file.Name)
            Application.StatusBar = "Processing " & index & " of " & files.count
            If (result) Then
                index = index + 1
            End If
        End If
    ' logError "allPrograms(): processed:", 0, directory & "\" & file
    Next file
    Application.ThisWorkbook.Activate
    Worksheets("Main").Cells(4, 3).Value = "Last Update: " + Format(Now(), "General Date")
End Sub

Function oneProgram(directory As String, fileName As String) As Boolean
    Dim wbk As Workbook
    Dim filePath As String
    Dim result As Boolean
    filePath = directory & "\" & fileName
    Set wbk = safeOpen(filePath, result)
    If (Not result) Then
        oneProgram = False
        Exit Function
    End If

    killSkillNames wbk
    clearProgSkills wbk
    copyDropList wbk
    copySkillsList wbk
    addSkillNames wbk
    addWinPercent wbk
    hideProgSheets wbk

    wbk.Close SaveChanges:=True
    oneProgram = True
End Function
Sub hideProgSheets(wbk As Workbook)
    wbk.Worksheets("SkillsList").Visible = False
    wbk.Worksheets("DropLists").Visible = False
End Sub
Sub copyDropList(wbk As Workbook)
    Dim source As Worksheet
    Dim target As range
    Dim dest As Worksheet
    Set source = Application.ThisWorkbook.Worksheets("DropLists")
    Set dest = wbk.Sheets("DropLists")
    wbk.Names("YesNoList").Delete
    Set target = wbk.Worksheets("StaffRequest").range("J3:K3")
    target.Validation.Delete 'delete previous validation
    Application.DisplayAlerts = False
        dest.Delete
    Application.DisplayAlerts = True
    source.Copy wbk.Sheets(Sheets.count)
    wbk.Names.Add Name:="YesNoList", RefersTo:=wbk.Sheets("DropLists").range("A1:A2")
End Sub
Sub addWinPercent(wbk As Workbook)
    Dim target As range
    wbk.Names.Add Name:="WinPercent", RefersTo:=wbk.Sheets("DropLists").range("B1:B5")
    Set target = wbk.Worksheets("StaffRequest").range("J3:K3")
    With target.Validation
        .Add Type:=xlValidateList, _
        Operator:=xlBetween, _
        AlertStyle:=xlValidAlertStop, _
        Formula1:="=WinPercent"
    End With
End Sub
Sub clearProgSkills(wbk As Workbook)
    Dim target As range
    Set target = wbk.Worksheets("StaffRequest").range("H10:J100")
    For Each cell In target
    If (cell.Value <> "") And (cell.Value <> "Total") Then
        cell.Value = "No Skill"
    End If
    Next cell
End Sub
Sub RUNME_PROGRAMS()
    allPrograms (ProgDir)
End Sub

Sub GetFilesRecursive(f As Scripting.Folder, filter As String, c As Collection, fso As Scripting.FileSystemObject)
  Dim sf As Scripting.Folder
  Dim file As Scripting.file

  For Each file In f.files
    If InStr(1, fso.GetExtensionName(file.Name), filter, vbTextCompare) = 1 Then
      c.Add file, file.path
    End If
  Next file

  For Each sf In f.SubFolders
    GetFilesRecursive sf, filter, c, fso
  Next sf
End Sub
Function safeOpen(filePath As String, result As Boolean) As Workbook
    result = True
    Dim book As Workbook
    Dim lockTest As Boolean
    Dim errCode As Integer
    Dim errText As String

    lockTest = IsWorkBookOpen(filePath, errCode, errText)
    If (lockTest) Then
        logError "safeOpen: Open Problem with: " & filePath, errCode, errText
        result = False
        Exit Function
    End If

    On Error Resume Next ' turn off error trapping
    Set book = Workbooks.Open(fileName:=filePath, ReadOnly:=False, UpdateLinks:=False)
    On Error GoTo 0 ' turn on error trapping
    If book Is Nothing Then
        logError "safeOpen: cannot Open File: " & filePath, errCode, errText
        result = False
    End If

    Set safeOpen = book
End Function

Function safeCellRead(rng As range) As Double
    If (IsNumeric(rng.Value)) Then
        safeCellRead = CDbl(rng.Value)
    Else
        safeCellRead = 0
    End If
End Function

Function IsWorkBookOpen(strFileName As String, errCode As Integer, errText As String) As Boolean

    On Error Resume Next
    ' If the file is already opened by another process,
    ' and the specified type of access is not allowed,
    ' the Open operation fails and an error occurs.
    Open strFileName For Binary Access Read Write Lock Read Write As #1
    Close #1

    errCode = Err.Number
    errText = Err.description
    'If no error, file is not open.
    If Err.Number = 0 Then
        IsWorkBookOpen = False
        End If

    'Error #70 is another user has the file open in edit mode.
    If Err.Number = 70 Then
        IsWorkBookOpen = True
        End If

    'Error #75 is another user has the file open in read only mode.
    If Err.Number = 75 Then
        IsWorkBookOpen = False
        End If
    On Error GoTo 0 ' turn on error trapping
End Function
Sub copySkillsList(wbk As Workbook)
    Dim source As Worksheet
    Dim dest As Worksheet
    Set source = Application.ThisWorkbook.Worksheets("SkillsList")
    Set dest = wbk.Sheets("SkillsList")
    dest.Unprotect Password:="****"
    Application.DisplayAlerts = False
        dest.Delete
    Application.DisplayAlerts = True
    source.Copy wbk.Sheets(Sheets.count)
End Sub
Sub killSkillNames(wkb As Workbook)
    Dim skills As Worksheet
    Dim range As range
    Dim tag As String
    Dim cell As range
    Set skills = wkb.Worksheets("SkillsList")
    Set range = skills.range("A1:AZ1")
    For Each cell In range
    If cell <> "" Then
        tag = cell.Value
        wkb.Names(tag).Delete
    End If
    Next cell
End Sub
Sub addSkillNames(wkb As Workbook)
    Dim skills As Worksheet
    Dim values As range
    Dim top As range
    Dim bottom As range
    Dim tag As String
    Dim cell As range
    Set skills = wkb.Worksheets("SkillsList")
    Set headers = skills.range("A1:AZ1")
    For Each cell In headers
    If cell <> "" Then
        tag = cell.Value
        Set top = cell.Offset(1, 0)
        Set bottom = top.End(xlDown)
        Set values = range(top, bottom)
        wkb.Names.Add Name:=tag, RefersTo:=values
    End If
    Next cell
End Sub
Sub clearErrors()
    Dim eSheet As Worksheet
    Set eSheet = Worksheets("ErrorLog")
    eSheet.range("A2:E4000").Clear
    eSheet.range("A1").Value = 1
    Application.DisplayStatusBar = True
    Application.StatusBar = ""
End Sub

Sub logError(errText As String, errNum As Integer, errDescription As String)
    Dim eSheet As Worksheet
    Dim eCount As Integer
    Set eSheet = ThisWorkbook.Worksheets("ErrorLog")
    eCount = CInt(eSheet.range("A1"))
    eCount = eCount + 1
    eSheet.Cells(eCount, 2).Value = errNum
    eSheet.Cells(eCount, 3).Value = errText
    eSheet.Cells(eCount, 4).Value = errDescription
    Application.StatusBar = "ERROR: " & eText
    eSheet.range("A1").Value = eCount
End Sub