valeur d'une cellule située n'importe où dans une colonne

Option Explicit
Private Numé As Double, Déno As Double, Term() As Double
Public Function Fraction(ByVal Nombre As Double) As String
   DévelopFract Nombre, 1
   AssembleFract
   Fraction = Numé & " / " & Déno
   End Function
Private Sub DévelopFract(ByVal Dde As Double, ByVal Dsr As Double, Optional ByVal PMax As Long = 40)
   Dim P As Long, QR As Double
   ReDim Term(1 To PMax) As Double
   For P = 1 To PMax
      QR = Int(Dde / Dsr): Term(P) = QR: QR = Dde - QR * Dsr: If QR = 0 Then Exit For
      Dde = Dsr: Dsr = QR: Next P
   If P < PMax Then ReDim Preserve Term(1 To P)
   End Sub
Private Sub AssembleFract(Optional ByVal P As Long = 40)
   Dim NvNu As Double
   P = LMin(UBound(Term), P): Numé = Term(P): Déno = 1
   While P > 1: P = P - 1: NvNu = Term(P) * Numé + Déno: Déno = Numé: Numé = NvNu: Wend
   End Sub
Function LMin(ByVal L1 As Long, ByVal L2 As Long) As Long
   LMin = (L1 - Abs(L1 - L2) + L2) \ 2
   End Function

=Fraction(B3)

Option Explicit
Private Numé As Double, Déno As Double, Term() As Double
Public Function Fraction(ByVal Nombre As Double, Optional ByVal P As Long = 0) As String
Rem Arguments à spécifier :
'  Nombre: Le nombre à analyser
'  P : Le numéro de la dernière partie fractionnaire inversée à appliquer.
'      Facultatf: 0 assumé.
'      Si spécifié <=0 ou non spécifié: la fraction calculée est celle de plus petit dénominateur
'         dont la division effectuée a le même code Double que le nombre à analyser.
'      Si spécifié > nombre de parties fractionnaires inversées trouvées, une chaine vide est renvoyée.
   DévelopFract Nombre, 1
   If P <= 0 Then
      P = 0
      Do: P = P + 1: If P > UBound(Term) Then Exit Do
         AssembleFract P: Loop Until Numé / Déno = Nombre
   ElseIf P > UBound(Term) Then
      Fraction = "": Exit Function
   Else: AssembleFract P: End If
   Fraction = Numé & " / " & Déno
   End Function
Private Sub DévelopFract(ByVal Dde As Double, ByVal Dsr As Double, Optional ByVal PMax As Long = 40)
   Dim P As Long, QR As Double
   ReDim Term(1 To PMax) As Double
   For P = 1 To PMax
      QR = Int(Dde / Dsr): Term(P) = QR: QR = Dde - QR * Dsr: If QR = 0 Then Exit For
      Dde = Dsr: Dsr = QR: Next P
   If P < PMax Then ReDim Preserve Term(1 To P)
   End Sub
Private Sub AssembleFract(Optional ByVal P As Long = 40)
   Dim NvNu As Double
   P = LMin(UBound(Term), P): Numé = Term(P): Déno = 1
   While P > 1: P = P - 1: NvNu = Term(P) * Numé + Déno: Déno = Numé: Numé = NvNu: Wend
   End Sub
Function LMin(ByVal L1 As Long, ByVal L2 As Long) As Long
   LMin = (L1 - Abs(L1 - L2) + L2) \ 2
   End Function

Option Explicit
Rem. Des Double sont utilisés dans ce module pour des entiers pouvant dépasser la capacité d'un Long.
Function Fraction(ByVal Nombre As Double, Optional ByVal P As Long = 0) As String
Rem. Renvoie le texte d'une fraction approchée d'un nombre.
'  Argument à transmettre :
'     Nombre: Le nombre à analyser
'     P : Le nombre de termes à employer (partie entière puis arrondis d'inverses des parties fractionnaires successives).
'        Facultatf: 0 assumé.
'        Si spécifié <=0 ou non spécifié: la fraction calculée est celle de plus petit dénominateur
'           dont la division effectuée a le même code Double que le nombre analysé.
'        Si spécifié > nombre de termes trouvés, une chaine vide est renvoyée.
   Dim TIPF() As Double, Numé As Double, Déno As Double ' Bien qu'entiers peuvent dépasser la capacité d'un Long
   DévelopFract TIPF, Nombre
   If P <= 0 Then
      P = 0
      Do: P = P + 1: If P > UBound(TIPF) Then Exit Do
         AssembleFract Numé, Déno, TIPF, P: Loop Until CDbl(Numé) / CDbl(Déno) = Nombre
   ElseIf P > UBound(TIPF) Then
      Fraction = "": Exit Function
   Else: AssembleFract Numé, Déno, TIPF, P: End If
   Fraction = Numé & " / " & Déno
   End Function
Sub DévelopFract(TIPF() As Double, ByVal Dde As Double, Optional ByVal Dsr As Double = 1, Optional ByVal PMax As Long = 40)
Rem. Calcule une liste de valeurs arrondies d'inverses de parties fractionnaires d'un nombre ou d'un rapport de nombres.
'  Argument à transmettre :
'     TIPF: La liste à initialiser des Inverses de Parties Fractionnaires (ou plutôt de leurs valeurs arrondies).
'     Dde: Le nombre ou le dividende du rapport.
'     Dsr: Le diviseur. Facultatif: 1 assumé.
'     PMax: Le nombre maximum d'IPF souhaitées. Facultatif: 40 assumé.
'  Remarque: Au final la liste TIPF ne sera au plus dimensionnée qu'au nombre d'IPF effectivement trouvées.
   Dim P As Long, QR As Double
   ReDim TIPF(1 To PMax) As Double
   For P = 1 To PMax
      QR = Int(Dde / Dsr + 0.5): TIPF(P) = QR: QR = Dde - QR * Dsr: If QR = 0 Then Exit For
      Dde = Dsr: Dsr = QR: Next P
   If P < PMax Then ReDim Preserve TIPF(1 To P)
   End Sub
Sub AssembleFract(ByRef Numé As Double, ByRef Déno As Double, TIPF() As Double, Optional ByVal P As Long = 40)
Rem. Calcule un numérateur et un dénominateur à partir d'une liste de valeur arrondies d'inverses de parties fractionnaires.
'  Argument à transmettre :
'     Numé: Numérateur à calculer
'     Déno: Dénominateur à calculer
'     TIPF: Liste des inverses des arrondis d'inverses de parties fractionnaires à appliquer.
'     P: Indice maximum de la dernière IPF à employer (en premier). Ramené à la dimension du tableau si spécifié supérieur.
   Dim Nu As Double, Dé As Double, NNu As Double
   If P > UBound(TIPF) Then P = UBound(TIPF)
   Nu = TIPF(P): Dé = 1
   While P > 1: P = P - 1: NNu = TIPF(P) * Nu + Dé: Dé = Nu: Nu = NNu: Wend
   Numé = Nu * Sgn(Dé): Déno = Abs(Dé)
   End Sub