Article ID: 192895
Article Last Modified on 1/23/2007
Option Base 1
'This macro deletes all formula links in a workbook.
'
'This macro does not delete a worksheet formula that references an open
'book, for example:
'
' =[Book1.xls]Sheet1!$A$1
'
' To delete only the links in the active sheet, see the comments
' provided in the Delete_It macro later in this article.
Public Times As Integer
Public Link_Array As Variant
Sub Should_Delete()
Items = 0 'initialize these names
Times = 0
Link_Array = ActiveWorkbook.LinkSources 'find all document links
Items = UBound(Link_Array) 'count the number of links
For Times = 1 To Items
'Ask whether to delete each link
Msg = "Do you want to delete this link: " & Link_Array(Times)
Style = vbYesNoCancel + vbQuestion + vbDefaultButton2
Response = MsgBox(Msg, Style)
If Response = vbYes Then Delete_It
If Response = vbCancel Then Times = Items
Next Times
End Sub
Sub Delete_It()
Count = Len(Link_Array(Times))
For Find_Bracket = 1 To Count - 1
If Mid(Link_Array(Times), Count - Find_Bracket, 1) = ":" _
Then Exit For
Next Find_Bracket
'Add brackets around the file name.
With_Brackets = Left(Link_Array(Times), Count - Find_Bracket) & _
"[" & Right(Link_Array(Times), Find_Bracket) & "]"
'Does the replace.
'If you want to remove links only on the active sheet, change the
'next two lines into comments by placing an (') apostrophe in front of
'them as well as the line, "Next Sheet_Select", that closes the loop.
For Each Sheet_Select In ActiveWorkbook.Worksheets
Sheet_Select.Activate
Set Found_Link = Cells.Find(what:=With_Brackets, After:=ActiveCell, _
lookin:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _
searchdirection:=xlNext, matchcase:=False)
While UCase(TypeName(Found_Link)) <> UCase("Nothing")
Found_Link.Activate
On Error GoTo anarray
Found_Link.Formula = Found_Link.Value
Set Found_Link = Cells.FindNext(After:=ActiveCell)
Wend
Next Sheet_Select 'To remove links only on the active sheet
'place an (') apostrophe at the front of this line.
Exit Sub
anarray:
Selection.CurrentArray.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues
Resume Next
End Sub
Additional query words: MacXLX XL2001 XL98
Keywords: kbdtacode kbhowto KB192895