Procédure VBA - Adresses absolues

Bonjour,

Je rencontre un petit souci, j'apprécierais votre aide si possible.

Je souhaite mettre en place une procédure VBA qui pourrait prendre une formule complexe utilisant des cellules exprimées en adresses relatives et la transformer en utilisant les mêmes cellules avec des adresses absolues.

Je vous remercie d'avance pour votre aide !

Bonne journée à vous :)

bonjour,

une petite procédure (à tester de manière approfondie sur des copies de ton fichier), qui transforme toutes les adresses relatives des formules se trouvant dans les cellules sélectionnées au moment du lancement de la procédure.

Sub reltoabs()
    For Each cel In Selection
        basec = cel.Column
        baser = cel.Row
        If cel.HasFormula Then
            f = cel.FormulaR1C1
            f = Replace(f, "C:", "C" & basec & ":")
            f = Replace(f, "C,", "C" & basec & ",")
            f = Replace(f, "C)", "C" & basec & ")")
            cel.FormulaR1C1 = f
            v = Split(f, "]")
            If UBound(v) > 0 Then
                nf = ""
                For i = LBound(v) To UBound(v)
                    v1 = Split(v(i), "[")
                    If UBound(v1) > 0 Then
                        If Right(v1(0), 1) = "R" Then
                            nf = nf & v1(0) & v1(1) + baser
                        ElseIf Right(v1(0), 1) = "C" Then
                            nf = nf & v1(0) & v1(1) + basec
                        End If
                    End If
                Next i
                cel.FormulaR1C1 = nf + v(UBound(v))
            End If
        End If
    Next
End Sub

Merci, mais ca ne repond qu'a moitié puisque le code ajoute bien $ avant la lettre de la colonne mais n'en rajoute pas un avant le numero de la ligne.

Bonjour,

peux-tu me donner un exemple de formule pour laquelle tu rencontres ce problème ?

Bonjour, voici un fichier explicatif du problème.

bonjour,

je ne peux pas être plus explicite pour exprimer mon besoin .

Je pense avoir bien compris ta demande, c'est juste que tu as rencontré un cas que je n'ai pas testé et c'est pourquoi je te demande la formule qui ne fonctionne pas.

La formule que tu as mise ne donne pas de problème. Mais en effet il y a bien des cas que je n'avais pas testés et sur lesquels la macro effectue le travail à moitié. A nouveau je n'ai pas tout testé, donc il est très probable que cette nouvelle solution ne fonctionne pas dans tous les cas. Si tu trouves une formule qui ne fonctionne pas, merci de mettre précisément cette formule dans son contexte, pour que je puisse reproduire le problème chez moi et adapter la macro.

essaie ceci, teste sur tes formules

Sub reltoabs()
    delim = ":,)+/*-><=&"
    For Each cel In Selection
        basec = cel.Column
        baser = cel.Row
        If cel.HasFormula Then
            f = trimformule(cel.FormulaR1C1)
            For i = 1 To Len(delim)
                d = Mid(delim, i, 1)
                f = Replace(f, "C" & d, "C" & basec & d)
                f = Replace(f, d & "RC", d & "R" & baser & "C")
            Next i
            cel.FormulaR1C1 = f
            v = Split(f, "]")
            If UBound(v) > 0 Then
                nf = ""
                For i = LBound(v) To UBound(v)
                    v1 = Split(v(i), "[")
                    If UBound(v1) > 0 Then
                        If Right(v1(0), 1) = "R" Then
                            nf = nf & v1(0) & v1(1) + baser
                        ElseIf Right(v1(0), 1) = "C" Then
                            nf = nf & v1(0) & v1(1) + basec
                        End If
                    End If
                Next i
                cel.FormulaR1C1 = nf + v(UBound(v))
            End If
        End If
    Next
End Sub

Function trimformule(f)
    newf = ""
    For i = 1 To Len(f)
        c = Mid(f, i, 1)
        If c = Chr(34) Then If fl = 1 Then fl = 0 Else fl = 1
        If c = Chr(32) And fl = 0 Then c = ""
        newf = newf & c
    Next i
    trimformule = newf
End Function

Oui, Désolée pour le commentaire, je partage le document avec un collègue et j'ai oublié de supprimer nos échanges et celui-ci avant d'envoyer le document.

J'ai trouvé une solution, ce code fonctionne:

Sub Convertir()

Dim cel As Range

For Each cel In Intersect(Selection, ActiveSheet.UsedRange)

If cel.HasFormula Then _

cel.Formula = Application.ConvertFormula(cel.Formula, xlA1, , True)

Next

End Sub

Merci encore pour ton aide et ta sollicitude, bonne après-midi et à bientôt peut-etre !

bonsoir,

beaucoup plus simple en effet, j'ai appris quelque chose. merci

Coucou H2,

Il est vrai qu'il est très très fort, et qu'en multi-postant, on peut, sans humilité, proposer bien mieux....

Bonne soirée