Sub propagatecomments()
'REQUIRES a reference to the Microsoft VBScript Regular Expressions 5.5 DLL
Const CAPAT = "([^\\:!\[\]]+)!(\$?[A-Z]{1,3}\$?\d{1,7})"
Const FNPAT = "\[([^\\:\[\]]+)\]"
Const DDPAT = "((\\\\[^\\:\[\]]+\\)|([A-Z]:\\))([^\\:\[\]]+\\)*"
Dim c As Range, rc As Range, re As New RegExp, mc As MatchCollection
Dim cf As String, fn As String, fnc() As String, j As Long, p As Long
On Error GoTo CleanUp
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
.EnableCancelKey = xlDisabled
.ScreenUpdating = False
End With
ReDim fnc(1 To 16)
re.Global = True
re.IgnoreCase = True
For Each c In ActiveSheet.UsedRange
'cell must contain both formula and comment
If Not c.HasFormula Then GoTo Continue
If c.NoteText = "" Then GoTo Continue
'remove initial = and single quotes (if any)
cf = Replace(Mid$(c.Formula, 2), "'", "")
fn = ""
p = 1
'check whether formula begins with drive/directory path
re.Pattern = DDPAT
Set mc = re.Execute(Mid$(cf, p))
'multiple paths means not a simple link formula, so abort
If mc.Count > 1 Then GoTo Continue
If mc.Count = 1 Then
With mc.Item(0)
'anything between pointer and path, abort
If .FirstIndex > 0 Then GoTo Continue
'simple link so far, so store path and advance pointer
fn = .Value
p = p + .Length
End With
End If
Set mc = Nothing
'check whether next piece of formula is [filename]
re.Pattern = FNPAT
Set mc = re.Execute(Mid$(cf, p))
'many bracketed text means not a simple link formula, so abort
If mc.Count > 1 Then GoTo Continue
If mc.Count = 1 Then
With mc.Item(0)
'anything between pointer and [filename], abort
If .FirstIndex > 0 Then GoTo Continue
'simple link so far, so append filename to nonblank path
'and advance pointer
If fn <> "" Then fn = fn & Mid$(.Value, 2, Len(.Value) - 2)
p = p + .Length
End With
End If
Set mc = Nothing
'check whether next piece of formula is single cell address
re.Pattern = CAPAT
Set mc = re.Execute(Mid$(cf, p))
'many cell addresses means not a simple link formula, so abort
If mc.Count > 1 Then GoTo Continue
If mc.Count = 1 Then
With mc.Item(0)
'anything between pointer and cell address, abort
If .FirstIndex > 0 Then GoTo Continue
'simple link so far, so advance pointer
p = p + .Length
End With
End If
Set mc = Nothing
'anything at or after pointer, abort
If Len(cf) >= p Then GoTo Continue
'at this point the formula is a simple link
'if fn is nonblank, it refers to a closed file which must be opened
If fn <> "" Then
j = j + 1
'expand fnc as needed by doubling its size
If j >= UBound(fnc, 1) Then ReDim Preserve fnc(1 To 2 * UBound(fnc, 1))
fnc(j) = fn
Workbooks.Open Filename:=fn, UpdateLinks:=0
End If
'get Range object reference to linked cell
Set rc = Evaluate(Mid$(c.Formula, 2))
If rc.NoteText = "" Then
c.Comment.Delete
Else
c.NoteText Text:=rc.NoteText, Start:=1
End If
Continue:
Next c
For j = j To 1 Step -1
fn = fnc(j)
Workbooks(Mid$(fn, InStrRev(fn, "\") + 1)).Close SaveChanges:=False
Next j
CleanUp:
With Application
.ScreenUpdating = True
.EnableCancelKey = xlInterrupt
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub
