Astuce du jour (Lister les cellule avec formule avec référence circulaire)

Sub test()
    Dim X
    X = GetCircularReference
    MsgBox Join(X, vbCrLf)
End Sub


Function GetCircularReference() As Variant
    'fonction patricktoulon
    'Recherche de ref circulaire et listage dans un tableau excel 2003 a excel 2024
    Dim circs As Range, refs As Collection, fml As String, cell As Range, memoire As Object
    With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: .CalculateFullRebuild: End With
    Set memoire = CreateObject("Scripting.Dictionary")
    Set refs = New Collection
    Do
        Set circs = ActiveSheet.CircularReference 'on capte la première
        If circs Is Nothing Then Exit Do 'on sort il y en a pas
        ' Mémorise la formule et l’adresse
        If Not memoire.Exists(circs.Address(External:=True)) Then
            refs.Add circs.Address(External:=True) 'si elle n'existe pas on l'ajoute a la collection
            memoire(circs.Address(External:=True)) = circs.Formula 'et on memorise dans le dico address/ref circulaire pour les remttre après
        End If
        circs.Formula = "'" & circs.Formula ' on commente la formule pour quelle ne soit pas trouvée au prochain tour
        Application.Calculate 'on calculate pour  pour que la feuille soit a jour en terme d'absence ou presence de ref circulaire
    Loop 'et on tourne  il prendra la suivante
    ' on remet le formules c'est pas compliqué a comprendre
    For Each cell In ActiveSheet.UsedRange
        If memoire.Exists(cell.Address(External:=True)) Then cell.Formula = memoire(cell.Address(External:=True))
    Next
    'on debloque tout
    With Application: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: End With
    ' si y a pas bye bye!!
    If refs.Count = 0 Then
        MsgBox "Aucune référence circulaire.", vbInformation
    Else
        'sinon on compile les addresse de refs circulaire
        ReDim tbl(1 To refs.Count)
        For i = 1 To refs.Count
            tbl(i) = refs(i)
        Next i
        GetCircularReference = tbl
    End If
End Function

Sub test()
   'ca marche meme si A1 n'est pas que la seule cellule dans le precedent
   Range("A1").DirectPrecedents.Select
    
End Sub


Sub test2()
    Dim cel As Range
    'a ben la ca marche plus
    For Each cel In ActiveSheet.UsedRange.Cells
        Set r = cel.DirectPrecedents '.DirectDependents
        If Not Intersect(r, cel) Is Nothing Then
            Debug.Print cel.Address(external:=True)
        End If
    Next
End Sub

Option Explicit
Private ClnCirc As Collection, CelRef As Range
Sub Test()
   Dim Cel As Range, TRapport() As String, N As Integer
   Set ClnCirc = New Collection
   Set CelRef = ActiveSheet.CircularReference
   If CelRef Is Nothing Then
      MsgBox "Pas de référence circulaire.", vbInformation
   Else
      PrécédentCirc
      ReDim TRapport(1 To ClnCirc.Count)
      For Each Cel In ClnCirc
         N = N + 1: TRapport(N) = Cel.Address(False, False, External:=True)
         Next Cel
      MsgBox "Circulaires :" & vbLf & Join(TRapport, vbLf), vbExclamation
      End If
   End Sub
Function PrécédentCirc(Optional ByVal Cel As Range) As Boolean
   Dim CelPr As Range, RngPr As Range
   If CelRef Is Nothing Then Exit Function
   If Cel Is Nothing Then Set Cel = CelRef
   On Error Resume Next
   Set RngPr = Cel.DirectPrecedents
   If Err Then Exit Function
   On Error GoTo 0
   If RngPr Is Nothing Then Exit Function
   For Each CelPr In RngPr
      If CelPr.Address(External:=True) = CelRef.Address(External:=True) Then PrécédentCirc = True: Exit For
      If PrécédentCirc(CelPr) Then PrécédentCirc = True: Exit For
      Next CelPr
   If PrécédentCirc Then
      On Error Resume Next
      ClnCirc.Add Cel, Key:=Cel.Address(External:=True)
      End If
   End Function