Macro VBA "Remplacer par" amélioré

Sub RemplacerPlages_Version1()
Dim rc&, w As Worksheet, c As Range, a As Range, s
rc = Worksheets(1).Rows.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For Each w In Worksheets
  For Each c In w.UsedRange.SpecialCells(xlCellTypeFormulas)
    For Each a In c.Precedents.Areas 'antécédents
      If a.Rows.Count = rc Then
        s = Split(a.Address(0, 0), ":")
        If InStr(c.Formula, s(0) & ":" & s(1)) Then
          c.Replace s(0) & ":" & s(1), s(0) & "$1:" & s(1) & "$1500", xlPart
        Else
          c.Replace s(0) & ":$" & s(1), s(0) & "$1:$" & s(1) & "$1500", xlPart
        End If
      End If
Next a, c, w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Sub RemplacerPlages_Version2()
Dim rc&, w As Worksheet, P As Range, c As Range, a As Range, s
rc = Worksheets(1).Rows.Count
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next
For Each w In Worksheets
  Set P = Nothing
  Set P = w.UsedRange.SpecialCells(xlCellTypeFormulas)
  For Each c In P
    For Each a In c.Precedents.Areas 'antécédents
      If a.Rows.Count = rc Then
        s = Split(a.Address(0, 0), ":")
        P.Replace s(0) & ":" & s(1), s(0) & "$1:" & s(1) & "$1500", xlPart
        P.Replace s(0) & ":$" & s(1), s(0) & "$1:$" & s(1) & "$1500"
      End If
Next a, c, w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Sub RemplacerPlages_Version3()
Dim d As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
On Error Resume Next 'sécurité
For Each w In Worksheets
  t = w.UsedRange.Formula 'matrice, plus rapide
  ncol = UBound(t, 2)
  For i = 1 To UBound(t)
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = Len(x) To 1 Step -1
            If Mid(x, k, 1) = ":" Then
              p = k - 1
              While d.exists(Mid(x, p, 1))
                p = p - 1
              Wend
              If Mid(x, p + 1, 1) <> ":" Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                If Mid(x, p - 1, 1) <> ":" Then
                  x = Left(x, k - 1) & "$1" & Mid(x, k, p - k) & "$1500" & Mid(x, p)
                  k = k - 2
                End If
              End If
            End If
          Next k
          t(i, j) = x
        End If
      End If
  Next j, i
  w.UsedRange.Formula = t 'restitution
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Sub RemplacerPlages_Version4()
Dim d As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each w In Worksheets
  t = w.UsedRange.Resize(w.UsedRange.Rows.Count + 1).Formula 'au moins 2 éléments
  ncol = UBound(t, 2)
  For i = 1 To UBound(t) - 1
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = Len(x) - 1 To 3 Step -1
            If Mid(x, k, 1) = ":" Then
              If d.exists(Mid(x, k - 1, 1)) Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                x = Left(x, k - 1) & "$1" & Mid(x, k, p - k) & "$1500" & Mid(x, p)
              End If
            End If
          Next k
          t(i, j) = x
        End If
      End If
  Next j, i
  On Error Resume Next
  w.UsedRange.Formula = t 'restitution
  If Err.Number > 0 Then MsgBox "Restitution bloquée en feuille '" & w.Name & "' : une formule est à revoir..."
  On Error GoTo 0
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

=zzz:zzz
=SOMME(A:A:DECALER(A:A;;1))

Sub RemplacerPlages_Version5()
Dim d As Object, df As Object, i&, w As Worksheet, t, ncol%, j%, x$, k%, p%, a, s
'---liste des caractères---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Set df = CreateObject("Scripting.Dictionary")
df.CompareMode = vbTextCompare 'la casse est ignorée
For i = 65 To 90 'codes des lettres de A à Z
  d(Chr(i)) = ""
Next i
d("$") = "" 'ajout du caractère "$"
'---traitement des formules de chaque feuille---
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each w In Worksheets
  t = w.UsedRange.Resize(w.UsedRange.Rows.Count + 1).Formula 'au moins 2 éléments
  ncol = UBound(t, 2)
  For i = 1 To UBound(t) - 1
    For j = 1 To ncol
      x = t(i, j)
      If Left(x, 1) = "=" Then
        If InStr(x, ":") Then
          For k = 3 To Len(x) - 1
            If Mid(x, k, 1) = ":" Then
              If d.exists(Mid(x, k - 1, 1)) Then
                p = k + 1
                While d.exists(Mid(x, p, 1))
                  p = p + 1
                Wend
                df(Mid(x, k - 1, p - k + 1)) = "" 'mémorisation sans doublon
              End If
            End If
          Next k
        End If
      End If
  Next j, i
  If df.Count Then
    a = df.keys
    For i = 0 To UBound(a)
      s = Split(a(i), ":")
      w.UsedRange.Replace a(i), s(0) & "$1:" & s(1) & "$1500", xlPart 'remplacement dans toute la feuille
    Next i
    df.RemoveAll 'RAZ du Dictionary
  End If
Next w
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub