Bezüge (Vorgänger /Precedents) aus Formel parsen

Sub Bezugsparsing()'Analysiert die aktive Zelle
Dim f As String, f1 As String, f2 As String, f3 As String
Dim x As Long, i As Long, j As Long
Dim Feld As Variant
Dim Delimiter As String
Dim strBezüge As String
ReDim Bezüge(1 To 1) As String
f = ActiveCell.Formula
'Trennzeichen für die Funktion Split. Diese Kombi darf selbst nicht in Tabellen- oder  _
Bereichsname vorkommen:
Delimiter = Chr(255) & Chr(250) & Chr(251) & Chr(253) & Chr(254)
For x = 1 To Len(f) 'Eliminiert Zeichenketten aus Formelausdruck
If Mid(f, x, 1) = "'" And i Mod 2 = 0 Then
j = j + 1
End If
If Mid(f, x, 1) = """" And j Mod 2 = 0 Then
i = i + 1
Else
If i Mod 2 = 0 Then f1 = f1 & Mid(f, x, 1)
End If
Next
j = 0
For x = 1 To Len(f1) 'ersetzt alle Operatoren durch den Delimiter. Außer in durch Hochkommata  _
eingegrenzten Tabellennamen
Select Case Mid(f1, x, 1)
Case "'"
j = j + 1
f2 = f2 & Mid(f1, x, 1)
Case "+", "/", "-", "*", "^", "(", ")", "}", "{", "&", ",", "=", "%", " "
If j Mod 2 = 0 Then
f2 = f2 & Delimiter
Else
f2 = f2 & Mid(f1, x, 1)
End If
Case Else
f2 = f2 & Mid(f1, x, 1)
End Select
Next
For x = 1 To 10 'kommt der Delimiter mehrmals hintereinander vor, werden die Doppler eliminiert
f2 = WorksheetFunction.Substitute(f2, Delimiter & Delimiter, Delimiter)
Next
Feld = Split(f2, Delimiter)
i = 0
For x = 1 To UBound(Feld) 'Potentielle Bezüge werden überprüft
If Left(Feld(x), 1) = ":" Then Feld(x) = Mid(Feld(x), 2)
If IstBezug(Feld(x)) Then  'Interne Bezüge werden überprüft
If IstKeineFunktion(Feld(x), f) Then 'Unterscheidet Funktionen von  _
Bereichsnamen
i = i + 1
ReDim Preserve Bezüge(1 To i)
Bezüge(i) = WorksheetFunction.Substitute(Feld(x), "$", "") 'damit $A$1 und  _
A1 identisch sind
End If
ElseIf IstExternerBezug(Feld(x)) Then 'Externe Bezüge auf geschlossene Dateien
i = i + 1
ReDim Preserve Bezüge(1 To i)
Bezüge(i) = WorksheetFunction.Substitute(Feld(x), "$", "")
ElseIf InStr(1, Feld(x), ":") > 1 Then 'Prüfung auf Sonderfall z.B. A1:INDEX(A:A;2)
f3 = Left(Feld(x), InStr(1, Feld(x), ":") - 1)
If IstBezug(f3) Then
i = i + 1
ReDim Preserve Bezüge(1 To i)
Bezüge(i) = WorksheetFunction.Substitute(f3, "$", "")
End If
End If
Next x
For x = 1 To UBound(Bezüge) 'Doppler eliminieren
If Application.Match(Bezüge(x), Bezüge, 0) = x Then
strBezüge = strBezüge & Bezüge(x) & vbCrLf
End If
Next
MsgBox strBezüge
End Sub

Function IstBezug(ByVal s As String) As Boolean
On Error Resume Next
Dim c As Range
Set c = Range(s)
If Not c Is Nothing Then
IstBezug = True
End If
End Function

Function IstExternerBezug(ByVal s As String) As Boolean
On Error GoTo ende
s = Application.ConvertFormula(s, xlA1, xlR1C1)
If Not IsError(Application.ExecuteExcel4Macro(s)) And IsError(Evaluate("=" & s)) Then
IstExternerBezug = True
End If
ende:
End Function

Function IstKeineFunktion(ByVal s As String, ByVal formel As String) As Boolean 'Prüft ob der  _
Bezug kein Name sondern eine 

Function ist
Dim AnzahlVorkommen As Long
Dim x As Long, i As Long
AnzahlVorkommen = (Len(formel) - Len(WorksheetFunction.Substitute(formel, s, ""))) / Len(s)
i = 1
For x = 1 To AnzahlVorkommen
i = InStr(i, formel, s)
If Mid(formel, i + Len(s), 1)  "(" Then
IstKeineFunktion = True
Exit Function
End If
i = i + 1
Next
End Function