VBA для обновления и замены в книгах вызывает сбой

Question

Пожалуйста, потерпите меня.Мой код, вероятно, полный дерьмо, поэтому я ценю все отзывы!Таким образом, в моей основной книге есть ряд гиперссылок UNC в строке M, которые ссылаются на файлы на диске раздела.

Что делает этот код:

1. Перейти вниз по списку гиперссылок в столбце M, открыть их и выполнить код внутри «С WBSsource».

2. Сначала выполняется поиск экземпляров неверного пути к файлу (st) внутри каждой из формул ячеек (NOT VALUES) и увеличивается счетчик с помощью InStr (t), затем после того, как рабочий лист былвыполненный поиск, если окончательное число (c) больше 0, что означает, что при поиске найден хотя бы один неверный путь к файлу, он перейдет к следующему шагу.

3. Выполняется замена Cells.Replaceна основе рабочего листа (ws.) (на уровне FORMULA)

4. Все ячейки на рабочем листе готовы, следует сохранить рабочую книгу и закрыть ее, прежде чем перейти к следующему.

5. Все ссылки, которые не удалось открыть, появятся в последнем всплывающем окне.

Именно на шаге 3 он начинает работать вяло и аварийно завершать работу.

Я изо всех сил стараюсь автоматизировать и сохранять рабочие книги.Затем, как только они все обновятся, повторный запуск этого кода будет намного быстрее, поскольку ему не придется заменять все снова.

Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer

' Update the individual credit models
With ThisWorkbook.ActiveSheet
    lr = .Cells(.Rows.Count, "M").End(xlUp).Row
    FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
    On Error Resume Next
    If FileNames(i, 1) Like "*.xls*" Then
        Set WBSsource = Workbooks.Open(FileNames(i, 1), _
                                       ReadOnly:=False, _
                                       Password:="", _
                                       UpdateLinks:=3)


            If Err = 0 Then
            With WBSsource
                Application.DisplayAlerts = False
                ActiveWorkbook.Final = False
                Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                Application.EnableEvents = False

                st = "\\corp\Accounts\" 'Search Phrase
                n = "\\corp\StackOverflow\Accounts\" 'New Phrase
                c = 0

                For Each ws In WBSsource.Worksheets
                    ws.Activate
                    t = 0
                    On Error Resume Next
                    For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
                        t = InStr(1, r.Formula, st)
                        If t > 0 Then
                            c = c + 1
                        End If
                    Next r
                Next ws

                If c > 0 Then
                    'MsgBox ws.Name & Chr(10) & (c)
                    ws.Cells.Replace st, n
                End If


                .UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
                Application.EnableEvents = True
                Application.Calculation = xlCalculationAutomatic
                Application.ScreenUpdating = True
                .Save
                .Close True

            End With
        Else
            msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
            On Error GoTo 0
        End If
    End If

    Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
    'MsgBox "The Following Files Could Not Be Opened" & _
    '       Chr(10) & msg, 48, "Error"

    Set objShell = CreateObject("Wscript.Shell")
        objShell.Popup "The Following Files Could Not Be Opened" & _
           Chr(10) & Chr(10) & msg, 48, "Error"
End If

Application.DisplayAlerts = True

End Sub

Answer 1

Это не совсем дерьмо.Я только что узнал, что мы можем создать массив с этим.

FileNames = .Range("M2:M" & lr).Value

Может произойти сбой, так как на 3-м шаге нет предела диапазона.Попробуйте получить последнюю строку и столбец на каждом листе, а затем создайте диапазон на основе этого.

With ws
    ' Get end cells
    With .Cells.SpecialCells(xlCellTypeLastCell)
        intLastRow = .Row
        intLastCol = .Column
    End With

    For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
        ' Check formula if it contains specific string
        t = InStr(1, r.Formula, st)
        If t > 0 Then
            c = c + 1
        End If

        ' Replace formula with new string
        r.Formula = Replace(r.Formula, st, n)
    Next r
End With

Редактировать: Вот полный код.Дайте мне знать, если это работает для вас.

Option Explicit

' Update the individual credit models
Sub List_UpdateAndSave()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ErrorHandler

    ' Declaration
    Dim i As Long
    Dim arrLinks As Variant
    Dim strLinksErr As String

    ' Initialization
    Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
    Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase

    With ThisWorkbook.ActiveSheet
        ' Get links from sheet
        arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
    End With

    For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
        ' Check for Excel links
        If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
            FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
        Else
            ' Add to list of links that could not be opened
            strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
        End If
    Next i

ErrorHandler:
    ' Display any errors
    If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number

    ' Display any non-Excel links
    If strLinksErr <> "" Then
        MsgBox "The following files could not be opened:" & _
                Chr(10) & strLinksErr, 48, "Error"
    End If

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub


Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
    Dim intLastRow As Long, intLastCol As Long
    Dim wbkTmp As Workbook
    Dim shtTmp As Worksheet
    Dim rngCell As Range

    ' Open link as workbook
    Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)

    With wbkTmp
        For Each shtTmp In .Worksheets
            With shtTmp
                ' Get end cells
                With .Cells.SpecialCells(xlCellTypeLastCell)
                    intLastRow = .Row
                    intLastCol = .Column
                End With

                For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
                    If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
                         rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
                    End If
                Next rngCell
            End With
        Next shtTmp

        .UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
        .Save
        .Close True
    End With
End Function