VBA to Update and Replace in Workbooks causes crashing - excel

Question

Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
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

It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
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
Edit: Here's the full code. Let me know if this works for you.
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