Raccourcis clavier pour ajouter des $ à la cellule

Sub Dollars()
Dim RgSel As Range, Rg As Range
Set RgSel = Selection
For Each Rg In RgSel: Dollars1Cel Rg: Next Rg
End Sub
Private Sub Dollars1Cel(ByVal Rg As Range)
Dim Lig As Long, Col As Long, ZOrg As String, ZRés As String, PDéb As Long, PFin As Long, _
   P As Long, C As String * 1, ZAlp As String
ZOrg = Rg.FormulaR1C1: ZRés = ZOrg
Lig = Rg.Row
Col = Rg.Column
PDéb = InStr(ZRés, "[")
While PDéb > 0
   PFin = InStr(PDéb, ZRés, "]")
   ZAlp = ""
   P = PDéb
   Do
      P = P - 1
      C = Mid$(ZRés, P, 1)
      If C = LCase(C) Then Exit Do
      ZAlp = C & ZAlp
      Loop
   If ZAlp = "R" Then
      ZRés = Left(ZRés, PDéb - 1) & Lig + Mid$(ZRés, PDéb + 1, PFin - PDéb - 1) & Mid$(ZRés, PFin + 1)
   ElseIf ZAlp = "C" Or ZAlp = "RC" Then
      ZRés = Left(ZRés, PDéb - 1) & Col + Mid$(ZRés, PDéb + 1, PFin - PDéb - 1) & Mid$(ZRés, PFin + 1)
   Else
      PDéb = PDéb + 1
      End If
   PDéb = InStr(PDéb, ZRés, "[")
   Wend
If ZRés <> ZOrg Then
   On Error Resume Next
   Application.Calculation = xlCalculationManual
   If Rg.HasArray Then
      Rg.CurrentArray.FormulaArray = ZRés
      If Err Then MsgBox "Range(" & Rg.CurrentArray.Address(True, True) & ").FormulaArray =" _
         & vbLf & """" & ZRés & """ ==> erreur " & Err.Number & " :" _
         & vbLf & Err.Description, vbExclamation, "Mettre les ""$""."
   Else
      Rg.FormulaR1C1 = ZRés
      If Err Then MsgBox "Range(" & Rg.Address(True, True) & ").FormulaR1C1 =" _
         & vbLf & """" & ZRés & """ ==> erreur " & Err.Number & " :" _
         & vbLf & Err.Description, vbExclamation, "Mettre les ""$""."
      End If
   Application.Calculation = xlCalculationAutomatic
   On Error GoTo 0
   End If
End Sub

Sub RemplaceRdifParDecaler()
Dim Rg As Range, ZSv As String, Z As String, dL As Long, P As Long, ZC As String, R As Long, Q As Long
For Each Rg In Selection
   ZSv = Rg.FormulaR1C1: Z = ZSv
   Do: P = InStr(Z, "R[")
      If P = 0 Then Exit Do
      Q = InStr(P + 2, Z, "]"): dL = Mid$(Z, P + 2, Q - P - 2)
      Q = Q + 1
      If Mid$(Z, Q, 1) = "C" Then
         ZC = Mid$(Z, Q)
         If Mid$(ZC, 2, 1) = "[" Then
            ZC = Left$(ZC, InStr(3, ZC, "]"))
         Else
            R = 1
            Do
               Q = R + 1
               If Q > Len(ZC) Then Exit Do
               If InStr("0123456789", Mid$(ZC, Q, 1)) = 0 Then Exit Do
               R = Q: Loop
            ZC = Left$(ZC, R)
            End If
      Else
         ZC = ""
         End If
      Z = Replace(Z, "R[" & dL & "]" & ZC, "OFFSET(R" & ZC & "," & dL & ",0)", , 1)
      Loop
   If ZSv <> Z Then Rg.FormulaR1C1 = Z
   Next Rg
End Sub

Sub FullAbsolute()
Dim FormRef As String

FormRef = Application.ConvertFormula(Formula:=Selection.Formula, fromreferencestyle:=Application.ReferenceStyle, toabsolute:=xlAbsolute)
Debug.Print FormRef
End Sub


Sub NotAbsolute()
Dim FormRef As String

FormRef = Application.ConvertFormula(Formula:=Selection.Formula, fromreferencestyle:=Application.ReferenceStyle, toabsolute:=xlRelative)
Debug.Print FormRef
End Sub


Sub AbsoluteColumn()
Dim FormRef As String, i As Long

'=$E$9+$E$10
FormRef = Application.ConvertFormula(Selection.Formula, Application.ReferenceStyle, xlA1, xlAbsolute)

For i = 65 To 90 'A - Z
FormRef = Replace(FormRef, Chr(i) & "$", Chr(i))
Next i

Debug.Print FormRef '=$E9+$E10

'Range("A1").Formula = FormRef
End Sub


Sub AbsoluteLign()
Dim FormRef As String, i As Long

'=$E$9+$E$10
FormRef = Application.ConvertFormula(Selection.Formula, Application.ReferenceStyle, xlA1, xlAbsolute)

For i = 65 To 90 'A - Z
FormRef = Replace(FormRef, "$" & Chr(i), Chr(i))
Next i

Debug.Print FormRef '=E$9+E$10

'Range("A1").Formula = FormRef
End Sub

xlAbsolute 1 Convertit au style de ligne et de colonne absolues. 
xlAbsRowRelColumn 2 Convertit au style de ligne absolue et de colonne relative. 
xlRelative 4 Convertit au style de ligne et de colonne relatives. 
xlRelRowAbsColumn 3 Convertit au style de ligne relative et de colonne absolue.