Почему мой код VBA делает sh при циклическом просмотре книг со ссылками? - PullRequest
Новая
       6

Почему мой код VBA делает sh при циклическом просмотре книг со ссылками?

1 голос
/ 21 февраля 2020

Код ниже предназначен для обновления указанной c ссылки (ссылка B2) для всех файлов Excel в данной папке (ссылка B1). Существует дополнительное условие, что файл будет сохранен только в том случае, если количество ошибок одинаково до и после.

Однако при запуске этого файла происходит сбой Excel без указания причины: 

Sub UpdateLinksWS()

    Application.ScreenUpdating = False

    Dim locWS, locWB As String
    Dim wb, ThisWB As Workbook
    Dim oFSO, oFolder, oFiles, oFile As Object
    Dim noErrors, i, j As Integer
    Dim Links As Variant

    'Access the file location with VBA objects
    locWS = Worksheets("Sheet").Range("B1").Value
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(locWS)
    Set oFiles = oFolder.Files
    i = 0
    Set ThisWB = ThisWorkbook

    'For each file in the path ...
    For Each oFile In oFiles
        'Set the pathname
        locWB = locWS & oFile.Name
        Set wb = Workbooks.Open(locWB)

        'Counts the number of errors in the workbook before updates
        noErrors = ErrorCount(wb)

        'Update links and calculate workbook - first checking the link to update or update all links
        If ThisWB.Worksheets("Sheet").Range("B2").Value = "" Then
            wb.UpdateLink Type:=xlExcelLinks
        Else
            'Check if the sheet is actually there
            Links = wb.LinkSources(xlExcelLinks) 'getLinks(wb)
            If Links <> Empty Then
                For j = 1 To UBound(Links)
                    If Links(j) = ThisWB.Worksheets("Sheet").Range("B2").Value Then
                        wb.UpdateLink Name:=Worksheets("Sheet").Range("B2").Value, Type:=xlExcelLinks
                    End If
                Next j
            End If
        End If
        Application.CalculateFull


        'If there's a different number of errors after the updates, close, list the workbook in Errors and don't save, otherwise save
        If ErrorCount(wb) = noErrors Then
        'Exit and save the changes
            Workbooks(oFile.Name).Close SaveChanges:=True
        Else
            Worksheets("Errors").Cells(2 + i, 2).Value = wb.Name
            Workbooks(oFile.Name).Close SaveChanges:=False
            i = i + 1
        End If
    Next

    Application.ScreenUpdating = True

End Sub


Function ErrorCount(ByVal wb As Workbook) As Integer
    Dim nbErrors As Integer
    Dim ws As Worksheet

    nbErrors = 0

    For Each ws In wb.Worksheets
        On Error GoTo NoErrs
        nbErrors = nbErrors + ws.Cells.SpecialCells(xlCellTypeFormulas, xlErrors).Count
    Next

    ErrorCount = nbErrors

NoErrs:
    Resume Next

End Function

Любые идеи приветствуются. Заранее спасибо.

...