Mit diesem Makro können Sie eine Arbeitsmappe nach Zirkelbezügen durchsuchen und auflisten

Das folgende Makro dient dazu, Zirkelbezüge in einer Arbeitsmappe zu suchen und in einem neuen Tabellenblatt aufzulisten. Ein Zirkelbezug tritt auf, wenn eine Zelle in einer Formel auf sich selbst oder auf eine andere Zelle verweist, die wiederum auf die ursprüngliche Zelle verweist. Das Makro ermöglicht es dem Benutzer, alle Zirkelbezüge in einer Excel-Arbeitsmappe zu identifizieren und zentral aufzulisten, was bei der Fehlerbehebung und der Analyse von komplexen Formeln hilfreich sein kann. Des Weiteren wird jedem Zirkelbezug in der Auflistung ein Hyperlink hinterlegt, so dass Sie direkt zu der entsprechenden Zelle mit dem Zirkelbezug springen können.

Sub Zirkelbezugs_Verzeichnis()
Dim tb As Integer
Dim a As Integer
Dim Zirkelbezuege As Worksheet
Dim tb_aktiv As Worksheet
Dim zaehler As Integer
Dim Zelle As Range
Dim Zirkelbezug As Boolean

Application.ScreenUpdating = False
Application.DisplayAlerts = False

tb = ActiveWorkbook.Worksheets.Count
For a = 1 To tb
If Worksheets(a).Name = "Zirkelbezüge" Then
MsgBox "Es besteht bereits ein Tabellenblatt mit dem Namen 'Zirkelbezüge'. Bitte lšschen Sie diese Tabellenblatt oder benennen Sie es um."
Exit Sub
End If
Next a
Worksheets.Add
ActiveSheet.Name = "Zirkelbezüge"
ActiveSheet.Cells(1, 1).Value = "Zelle"
ActiveSheet.Cells(1, 2).Value = "Formel"
Set Zirkelbezuege = ActiveSheet
tb = ActiveWorkbook.Worksheets.Count
zaehler = 2
For a = 1 To tb
Set tb_aktiv = Worksheets(a)
tb_aktiv.Activate
On Error GoTo Fehler
For Each Zelle In tb_aktiv.UsedRange
If Left(Zelle.Formula, 1) = "=" Then
Zirkelbezug = Intersect(tb_aktiv.Range(Zelle.Address), tb_aktiv.Range(Zelle.Precedents.Address))
Zirkelbezuege.Hyperlinks.Add Anchor:=Sheets("Zirkelbezüge").Cells(zaehler, 1), Address:="", SubAddress:= _
"'" + tb_aktiv.Name + "'!" + Zelle.Address(False, False), ScreenTip:="Hyperlink", _
TextToDisplay:=tb_aktiv.Name + "'!" + Zelle.Address(False, False)
Zirkelbezuege.Cells(zaehler, 2).Value = " " & Zelle.Formula
zaehler = zaehler + 1
Weiter:
End If
Next
Next a
Exit Sub
Fehler:
Resume Weiter

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Weitere interessante Links zu diesem Thema: