Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
Dim c As Range, dp As Range, a As Range, i&, b As Range, btxt
Dim j%, k%, conv As Boolean, t$, adr$, n As Byte, p%, q%
Application.ScreenUpdating = False
[B:B].ClearContents 'RAZ
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
If c.HasFormula Then c(1, 2) = "'" & c.FormulaLocal
Next
On Error Resume Next 's'il n'y a pas d'antécédents
Set dp = [A:A].DirectPrecedents 'antécédents
On Error GoTo 0
If dp Is Nothing Then Exit Sub
Set a = dp(1): For Each c In dp: Set a = Range(a, c): Next
For i = a.Rows.Count To 1 Step -1
Set b = Intersect(a.Rows(i), dp)
If Not b Is Nothing Then
For Each b In b
btxt = IIf(IsNumeric(b) Or IsError(b), b.Text, """" & b.Text & """")
For Each c In b.DirectDependents 'dépendants
For j = 1 To 0 Step -1
For k = 1 To 0 Step -1
conv = False: t = c(1, 2): adr = b.Address(j, k): n = Len(adr)
For p = Len(t) To 2 Step -1
q = IIf(p = 2, 2, p - 2)
If Mid(t, p, n) = adr Then _
If InStr(Mid(t, q, n + 3), ":") = 0 Then _
t = Left(t, p - 1) & btxt & Mid(t, p + n): conv = True
Next p
If conv Then c(1, 2) = "'" & t
Next k, j, c, b
End If
Next i
'=================================
On Error Resume Next
For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))
c.ClearComments
If c.HasFormula Then
c.AddComment c.Offset(0, 1).Text
Else
c.ClearComments
End If
c.Offset(0, 1).ClearContents
Next
'================================='
End Sub