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

[patricktoulon]

Bonjour à tous
une demande recente a été faite sur ce point par @Dudu2
comment lister les reference circulaires d'une feuille ou celle qui son inscrit dans le menu dans le ruban onglet formules

1° ma réponse est simple
lire les données de ce contrôle du ruban n'est pas possible car ce menu est de type XMLtypeTag "DynamicMenu"(voir les démos du creatorRibbonX sur ce contrôle menu un peu particulier )qui se charge lors du drop "invalidatecontentOnDrop" sans invalidate du ruban
du coup cette piste on peut oublier(c'est comme si on fouillait une boite vide)

par contre excel a depuis 2003 la possibilité en vba de lister les références circulaires avec le membre .CircularReference
d'une feuille
sauf que il donne que la première
que ce vous tienne
on va lister et a chaque ref circulaire trouvées on commente la formule (bloque la formule)
ainsi si on relance il passe a la suivante etc.. etc...
une fois toute les ref circulaire trouvées et listée dans une collection /dico ,on sort de la boucle et on débloque les formules
nous reste plus a dimensionner un tableau a la collection et renvoyer un tableau d'addresse style macro4 (pour le fun)
et voila comment née une fonction

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

patrick

 

[Dranreb]

Bonsoir.
On devrait pouvoir faire mieux avec des procédures récursives utilisant la méthode DirectDependents ou DirectPrecedents …

 

[patricktoulon]

Bonjour @Dranreb essaie donc tu verra

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

ca va s'arrêter à la première et c'est normal et apres erreur !!!!

 

[Dranreb]

Bonjour.
J'essaie comme ça déjà :

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