Private Sub RemoveAllLinked_test()
Call RemoveAllLinked(ActiveWorkbook)
End Sub
Private Sub RemoveAllLinked(Optional ByVal book As Workbook)
On Error Resume Next
Dim b As Boolean, E As Boolean, test As Boolean, removeSheet As Boolean
Dim sh As Worksheet, ws As Worksheet, Named As Name, chtob As ChartObject
Dim rCell As Range, rg As Range, rg2 As Range
Dim c As Collection, srs As Series
Dim o, j%, i, fx$, action$, i1, i2, k&, s$, re, reFX
Dim cs, adr$, adr2$, f1$, ff$, f2$, d, t, op, ms, m:
Set re = glbRegex: Set reFX = glbRegex
re.Pattern = "^'?(?:''!|''|[^""])+?'?!"
reFX.Pattern = "(')(\[(?:''!|''|[^""\[\]])+?\])((?:''!|''|[^\[\]\/\\])+?)'!|" & _
"(\[[A-Za-z0-9._]+?\])([A-Za-z0-9._]+?)!"
If book Is Nothing Then Set book = ActiveWorkbook
Application.DisplayAlerts = False
GoSub Shapes
GoSub Names
GoSub DataValidation
GoSub Series
GoSub Formulas
Application.DisplayAlerts =True
Err.Clear
Exit Sub
Shapes:
For Each sh In book.Worksheets
For Each i1 In sh.Shapes
Set i = i1
Select Case TypeName(i1)
Case "GroupObject": For Each i2 In i1.GroupItems: Set i = i2: GoSub Shape: Next
Case Else: GoSub Shape
End Select
Next
Next
Return
Shape:
GoSub ShapeAction
GoSub ShapeFx
Return
ShapeAction:
action = "": action = i.OnAction: If action <> Empty Then GoSub action: If test Then i.OnAction = action
Return
ShapeFx:
fx = "": fx = i.DrawingObject.Formula: If fx <> Empty Then GoSub fx: If test Then i.DrawingObject.Formula = "=" & fx
Return
Names:
For Each Named In book.Names
fx = Named.RefersTo:
GoSub fx: If test Then Named.RefersTo = fx:
Next
Return
DataValidation:
For Each sh In book.Worksheets
Err.Clear: Set rg = sh.Cells.SpecialCells(xlCellTypeAllValidation)
If Not rg Is Nothing And Err = 0 Then
For Each rCell In rg
With rCell.Validation
b = False: f1 = "": f2 = "": f1 = .Formula1: f2 = .Formula2: t = .Type: op = .Operator
If f2 = Empty Then
fx = f1: GoSub fx: b = test
Else
fx = f2: GoSub fx: If test Then f2 = fx: b = True
fx = f1: GoSub fx: If test Then f1 = fx: b = True
End If
If b Then
If f2 = Empty Then
.Modify Type:=t, Operator:=op, Formula1:=fx
Else
.Modify Type:=t, Operator:=op, Formula1:=f1, Formula2:=f2
End If
End If
End With
Next
End If
Next
Return
FormatConditions:
For Each sh In book.Worksheets
Err.Clear: Set rg = sh.Cells.SpecialCells(xlCellTypeAllFormatConditions).Cells
If Not rg Is Nothing And Err = 0 Then
Set d = glbDict
For Each rCell In rg
Set cs = rCell.FormatConditions
For i = 1 To cs.Count
With cs(i)
f1 = "": f2 = "": adr = ""
f1 = .Formula1: f2 = .Formula2: adr = .AppliesTo.Address
t = .Type: op = .Operator
ff = f1 & "_" & f2 & "_" & t & "_" & op & "_" & adr
End With
If Not d.exists(ff) And (f1 <> Empty Or f2 <> Empty) And adr <> Empty Then
d.Add ff, "": b = False
If f2 = Empty Then
fx = f1: GoSub fx: b = test
Else
fx = f2: GoSub fx: If test Then f2 = fx: b = True
fx = f1: GoSub fx: If test Then f1 = fx: b = True
End If
If b Then
Set rg2 = sh.Range(adr)
If f2 = Empty Then
rg2.FormatConditions(1).Modify Type:=t, Operator:=op, Formula1:=fx
Else
rg2.FormatConditions(1).Modify Type:=t, Operator:=op, Formula1:=f1, Formula2:=f2
End If
End If
End If
Next i
Next rCell
End If
Next
Return
Series:
For Each sh In book.Worksheets
For Each chtob In sh.ChartObjects
For Each srs In chtob.SeriesCollection
fx = srs.Formula: GoSub fx: If test Then srs.Formula = fx
Next
Next
Next
Return
Formulas:
Set c = New Collection
For Each sh In book.Worksheets
adr = "": Set rg = Nothing:
If c.Count Then
For Each m In c
sh.Cells.Replace What:=m(0), Replacement:=m(1), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End If
fxs: b = False
Err.Clear: Set rg = sh.Cells.SpecialCells(xlCellTypeFormulas)
If Err = 0 And Not rg Is Nothing Then
Err.Clear: Set rg2 = rg.Find(What:="*[*]*!*", LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Err = 0 And Not rg2 Is Nothing Then
adr = rg2.Address(0, 0): fx = rg2.Formula
With reFX
test = .test(fx)
If test Then
Set ms = .Execute(fx)
For m = 0 To ms.Count - 1
Set o = ms(m).submatches
adr = ms(m)
Err.Clear: Set ws = book.Worksheets(o(2) & o(4))
s = IIf(Err, "", o(0) & o(2) & o(4) & o(0) & "!")
Err.Clear: c.Add Array(adr, s), adr
If Err = 0 Then
If Not b Then b = True
sh.Cells.Replace What:=adr, Replacement:=s, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End If
Next
If b Then GoTo fxs
End If
End With
End If
End If
Next
Return
action:
With re:
test = .test(action)
If test Then action = .Replace(action, "")
End With
Return
fx:
With reFX
test = .test(fx)
If test Then
Set ms = .Execute(fx)
For m = 0 To ms.Count - 1
Set o = ms(m).submatches
adr = ms(m)
Debug.Print "fx: "; adr, o.Count
Err.Clear: Set ws = book.Worksheets(o(2) & o(4))
fx = Replace(fx, adr, IIf(Err, "", o(0) & o(2) & o(4) & o(0) & "!"), Compare:=1)
Next
End If
End With
Return
End Sub
