VBA code to remove external links in Excel 365 fails due to Microsoft patch updates after years of working...

[Garland]

VBA code to remove external links in Excel 365 fails due to Microsoft patch updates.

Long story short: I had code that has been working for years that suddenly breaks due to Microsoft patch update. The VBA code I wrote copies several worksheets to a new workbook. I have links with named ranges which were able to normally convert to hard-coded values upon breaking the link, and now doesn't break and I'm getting "$NAME?" errors everywhere. I have tried to change security settings for macro security "Enable VBA macros (not recommended; potentially dangerous code can run)", but that fails too.

Screenshots below.

/* partial code only */

Dim strPath As String
Dim strFileName As String
Dim wkb, wkbDisk As Workbook
Dim boolAlert As Boolean
Dim astrLinks As Variant
Dim iCtr As Long

Set wkb = ThisWorkbook

Application.Calculation = xlManual

Application.Calculate

strPath = wkb.Sheets("Working Area").Range("WorkbookPath").Value
strFileName = wkb.Sheets("Working Area").Range("WorkbookName").Value

astrLinks = wkbDisk.LinkSources(Type:=xlLinkTypeExcelLinks)

/* code fails in next portion where it's supposed to break link to */

If IsArray(astrLinks) Then
For iCtr = LBound(astrLinks) To UBound(astrLinks)
wkbDisk.BreakLink Name:=astrLinks(iCtr), _
Type:=xlExcelLinks
Next iCtr
End If
/* end of code containing VBA error */
Call NoNames
astrLinks = wkbDisk.LinkSources(Type:=xlLinkTypeExcelLinks)
'Application.Calculate
If IsArray(astrLinks) Then
For iCtr = LBound(astrLinks) To UBound(astrLinks)
wkbDisk.BreakLink Name:=astrLinks(iCtr), _
Type:=xlExcelLinks
Next iCtr
End If

Sub NoNames()
Dim n As Name
On Error Resume Next
For Each n In ActiveWorkbook.Names
n.Delete
Next n
On Error GoTo 0
End Sub

In main workbook:

When moved over, the formulas with named ranges remain:

 

[Fluff]

Welcome to the MrExcel Message Board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: VBA code to remove external links in Excel 365 fails due to Microsoft patch updates after
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[beginnerVBAexpert]

I ran into the same problem and have tabled it for a long time. I finally got back into the issue today. I think you may need to tweak this code a little for the extra sheets but I think it will finally solve your problem. I hope this helps you out.

Sub Find_namedrange_place()
Application.Calculation = xlCalculationManual


Dim xRg As Range
Dim xCell As Range
Dim xSht As Worksheet
Dim xFoundAt As String
Dim xAddress As String
Dim xShName As String
Dim xSearchName As String

On Error GoTo LinksCleared
Set Destwb = ActiveWorkbook

    ExternalLinks = Destwb.LinkSources(Type:=xlLinkTypeExcelLinks)

    For I = 1 To UBound(ExternalLinks)
        Destwb.BreakLink ExternalLinks(I), 1
        Debug.Print (ExternalLinks(I))
    Next I

LinksCleared:

On Error Resume Next

Set NmArray = CreateObject("System.Collections.ArrayList")
Set NmArrayDel = CreateObject("System.Collections.ArrayList")

For Each nm In ActiveWorkbook.Names
  If InStr(nm, "C:\") > 1 Then
    NmArray.Add nm.Name
    NmArrayDel.Add nm
  End If
Next nm


For Each nm In ActiveWorkbook.Names
  If InStr(nm, "[") > 1 Then
    NmArray.Add nm.Name
    NmArrayDel.Add nm
  End If
Next nm




xShName = Application.ActiveSheet.Name

Set xSht = Application.Worksheets(xShName)
Set xRg = xSht.Cells.SpecialCells(xlCellTypeFormulas)

On Error GoTo 0


For Each NmdRng In NmArray
    If Not xRg Is Nothing Then
        xSearchName = NmdRng
        Set xCell = xRg.Find(What:=xSearchName, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not xCell Is Nothing Then
            xAddress = xCell.Address
            If IsPresent(xCell.Formula, xSearchName) Then
                xFoundAt = xCell.Address
            End If      
            Do      
            Set xCell = xRg.FindNext(xCell)
            If Not xCell Is Nothing Then
                If xCell.Address = xAddress Then Exit Do
                    If IsPresent(xCell.Formula, xSearchName) Then
                        Range(xCell.Address).Formula = Range(xCell.Address).Value
                    End If
                Else
                    Exit Do
                End If
            Loop
        End If
        On Error Resume Next
    End If
Next NmdRng

For Each NmdRng In NmArrayDel
    NmdRng.Delete
Next


End Sub


Private Function IsPresent(sFormula As String, sName As String) As Boolean
Dim xPos1 As Long
Dim xPos2 As Long
Dim xLen As Long
Dim I As Long
xLen = Len(sFormula)
xPos2 = 1
Do
xPos1 = InStr(xPos2, sFormula, sName) - 1
If xPos1 < 1 Then Exit Do
IsPresent = IsVaildChar(sFormula, xPos1)
xPos2 = xPos1 + Len(sName) + 1
If IsPresent Then
If xPos2 <= xLen Then
IsPresent = IsVaildChar(sFormula, xPos2)
End If
End If
Loop
End Function


Private Function IsVaildChar(sFormula As String, Pos As Long) As Boolean
Dim I As Long
IsVaildChar = True
For I = 65 To 90
If UCase(Mid(sFormula, Pos, 1)) = Chr(I) Then
IsVaildChar = False
Exit For
End If
Next I
If IsVaildChar = True Then
If UCase(Mid(sFormula, Pos, 1)) = Chr(34) Then
IsVaildChar = False
End If
End If
If IsVaildChar = True Then
If UCase(Mid(sFormula, Pos, 1)) = Chr(95) Then
IsVaildChar = False
End If
End If
End Function