Question

请忍受我。我的代码可能是完整的东西，因此，我感谢所有反馈！所以这样做是在我的主要工作簿上，在M行中有一堆UNC超链接，这些超链接链接到节驱动器中的文件。

此代码的作用：

在M列中的超链接列表中向下移动，将其打开并执行“ With WBSsource”内部的代码。
首先，它在每个单元格公式（“无值”）中搜索错误文件路径（st）的实例，并使用InStr（t）递增计数器，然后在搜索工作表后，如果最终计数（c）大于0，表示搜索发现至少一个错误的文件路径，它将继续进行下一步。
它执行Cells.Replace在工作表（ws。）上（在FORMULA级别）
每个工作表中的单元格都已完成，应该保存工作簿并关闭，然后再移至下一个工作簿。
所有无法打开的链接将显示在最终弹出窗口中。

通过第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

由于第三步没有范围限制，因此可能会崩溃。尝试获取每个工作表的最后一行和最后一列，然后根据此范围创建一个范围。

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

在工作簿中更新和替换的VBA导致崩溃

1 个答案: