Add-In: Verknüpfungen suchen

Sub Menü()
Dim MenüLeiste As CommandBar
Dim neuesMenü As CommandBarControl, neuerEintrag As CommandBarControl
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls("Verknüpfungen").Delete
Set MenüLeiste = CommandBars.ActiveMenuBar
Set neuesMenü = MenüLeiste.Controls.Add(Type:=msoControlPopup, Temporary:=True)
neuesMenü.Caption = "&Verknüpfungen"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Temporary:=True)
neuerEintrag.Caption = "&Verknüpfungen suchen"
neuerEintrag.OnAction = "Suchen"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Temporary:=True)
neuerEintrag.Caption = "Verknüpfungen nur &auflisten"
neuerEintrag.OnAction = "Auflisten"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Temporary:=True)
neuerEintrag.Caption = "&Anleitung"
neuerEintrag.OnAction = "Anleitung"
neuerEintrag.BeginGroup = True
Set MenüLeiste = Nothing
Set neuesMenü = Nothing
Set neuerEintrag = Nothing
End Sub

Sub Menü_weg()
On Error Resume Next
Application.CommandBars("Worksheet Menu Bar").Controls("Verknüpfungen").Delete
End Sub

Sub Suchen()
Dim rngGefundeneZelle As Range
Dim intI%, intN%, intAbfrage%, intZähler%, intNamenAbfrage%, intLöschZähler%
Dim strSuchbegriff$, strAktuelleZelle$, strErsteZelle$
Dim objName As Object
Dim strAktMappe As String, strAktBlatt As String
Dim strAuswertung As String
Dim objAuswertung As Object
Dim lngZ As Long
strAktMappe = ActiveWorkbook.Name
strAktBlatt = ActiveSheet.Name
Workbooks.Add
Sheets.Add
ActiveSheet.Name = "Verknüpfungen"
Set objAuswertung = Workbooks(ActiveWorkbook.Name).Sheets("Verknüpfungen")
strAuswertung = ActiveWorkbook.Name
Workbooks(strAktMappe).Activate
Sheets(strAktBlatt).Select
strSuchbegriff = "]"
If strSuchbegriff = "" Then Exit Sub
ReDim strBereiche(0)
ReDim intBlätter(0)
intZähler = 0
lngZ = 2
For intI = 1 To Worksheets.Count
If Sheets(intI).ProtectContents Then
MsgBox "Das Blatt " & Sheets(intI).Name & " ist geschützt." & Chr(10) & "Entfernen Sie  _
bitte zuerst den Blattschutz.", vbOKOnly + vbInformation, "Blatt geschützt!"
objAuswertung.Cells(lngZ, 1) = Sheets(intI).Name & " geschützt, Schutz aufheben."
lngZ = lngZ + 1
GoTo nächstesBlatt
End If
Set rngGefundeneZelle = Worksheets(intI).Cells.Find(strSuchbegriff, lookat:=xlPart, LookIn:= _
xlFormulas)
If Not rngGefundeneZelle Is Nothing Then
'erste gefundene Zelle auf dem aktuellen Blatt:
strErsteZelle = rngGefundeneZelle.Address(False, False)
intZähler = intZähler + 1
ReDim Preserve intBlätter(intZähler)
ReDim Preserve strBereiche(intZähler)
intBlätter(intZähler - 1) = intI
strBereiche(intZähler - 1) = strErsteZelle
Do While strAktuelleZelle  strErsteZelle
'nächste gefundene Zelle(n) auf dem aktuellen Blatt
Set rngGefundeneZelle = Worksheets(intI).Cells.FindNext(after:=rngGefundeneZelle)
strAktuelleZelle = rngGefundeneZelle.Address(False, False)
If strErsteZelle  strAktuelleZelle Then
intZähler = intZähler + 1
ReDim Preserve intBlätter(intZähler)
ReDim Preserve strBereiche(intZähler)
intBlätter(intZähler - 1) = intI
strBereiche(intZähler - 1) = strAktuelleZelle
End If
Loop
strAktuelleZelle = ""
strErsteZelle = ""
End If
nächstesBlatt:
Next
Set rngGefundeneZelle = Nothing
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Verknüpfungen in Formeln"
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Blattname"
objAuswertung.Cells(lngZ, 2) = "Zelle"
objAuswertung.Cells(lngZ, 3) = "Formel"
objAuswertung.Cells(lngZ, 4) = "Wert"
objAuswertung.Cells(lngZ, 5) = "Aktion"
objAuswertung.Range(objAuswertung.Cells(lngZ - 1, 1), objAuswertung.Cells(lngZ, 5)).Font.Bold =  _
True
lngZ = lngZ + 1
intLöschZähler = 0
For intN = 0 To intZähler - 1
Sheets(intBlätter(intN)).Select
Range(strBereiche(intN)).Select
objAuswertung.Cells(lngZ, 1) = Sheets(intBlätter(intN)).Name    'Blattname
objAuswertung.Cells(lngZ, 2) = strBereiche(intN)                'Zelle
objAuswertung.Cells(lngZ, 3) = "'" & ActiveCell.Formula         'Formel
objAuswertung.Cells(lngZ, 4) = ActiveCell                       'Wert
objAuswertung.Cells(lngZ, 5) = "erhalten"                       'Aktion
intAbfrage = MsgBox("Auf dem Blatt " & Sheets(intBlätter(intN)).Name & " wurde in der Zelle  _
" & strBereiche(intN) & " eine Verknüpfung gefunden." & Chr(10) & "Die Formel lautet:" & Chr(10) & Chr(10) & ActiveCell.Formula & Chr(10) & Chr(10) & "Soll sie gelöscht und durch deren Wert ersetzt werden?", vbYesNo + vbQuestion, "Verknüpfung gefunden")
If intAbfrage = vbYes Then
Range(strBereiche(intN)) = Range(strBereiche(intN))
objAuswertung.Cells(lngZ, 5) = "gelöscht, durch Wert ersetzt"                       ' _
Aktion
intLöschZähler = intLöschZähler + 1
End If
lngZ = lngZ + 1
Next
lngZ = lngZ + 1
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Verknüpfungen in Namen"
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Name"
objAuswertung.Cells(lngZ, 2) = "bezieht sich auf"
objAuswertung.Cells(lngZ, 5) = "Aktion"
objAuswertung.Range(objAuswertung.Cells(lngZ - 1, 1), objAuswertung.Cells(lngZ, 5)).Font.Bold =  _
True
lngZ = lngZ + 1
For Each objName In ActiveWorkbook.Names
If InStr(1, objName.Value, strSuchbegriff) > 1 Then
intZähler = intZähler + 1
objAuswertung.Cells(lngZ, 1) = objName.Name
objAuswertung.Cells(lngZ, 2) = "'" & objName.Value
objAuswertung.Cells(lngZ, 5) = "erhalten"
intNamenAbfrage = MsgBox("In einem Namen besteht eine Verknüpfung." & Chr(10) & " _
Bezieht sich auf: " & objName.Value & Chr(10) & "Name: " & objName.Name, vbYesNo + vbQuestion, "Soll der Name gelöscht werden?")
If intNamenAbfrage = vbYes Then
objName.Delete
objAuswertung.Cells(lngZ, 5) = "gelöscht"
intLöschZähler = intLöschZähler + 1
End If
lngZ = lngZ + 1
End If
Next
If intZähler = 0 Then
MsgBox "Keine Verknüpfung gefunden oder die Blätter sind geschützt.", vbOKOnly +  _
vbInformation, "Fertig!"
Else
MsgBox "Es wurden insgesamt " & intZähler & " Verknüpfung(en) gefunden und davon " & intLö _
schZähler & " gelöscht.", vbOKOnly + vbInformation, "Fertig!"
End If
Set objAuswertung = Nothing
Set objName = Nothing
Workbooks(strAuswertung).Activate
End Sub

Sub Auflisten()
Dim rngGefundeneZelle As Range
Dim intI%, intN%, intAbfrage%, intZähler%, intNamenAbfrage%, intLöschZähler%
Dim strSuchbegriff$, strAktuelleZelle$, strErsteZelle$
Dim objName As Object
Dim strAktMappe As String, strAktBlatt As String
Dim strAuswertung As String
Dim objAuswertung As Object
Dim lngZ As Long
strAktMappe = ActiveWorkbook.Name
strAktBlatt = ActiveSheet.Name
Workbooks.Add
Sheets.Add
ActiveSheet.Name = "Verknüpfungen"
Set objAuswertung = Workbooks(ActiveWorkbook.Name).Sheets("Verknüpfungen")
strAuswertung = ActiveWorkbook.Name
Workbooks(strAktMappe).Activate
Sheets(strAktBlatt).Select
strSuchbegriff = "]"
If strSuchbegriff = "" Then Exit Sub
ReDim strBereiche(0)
ReDim intBlätter(0)
intZähler = 0
lngZ = 2
For intI = 1 To Worksheets.Count
If Sheets(intI).ProtectContents Then
MsgBox "Das Blatt " & Sheets(intI).Name & " ist geschützt." & Chr(10) & "Entfernen Sie  _
bitte zuerst den Blattschutz.", vbOKOnly + vbInformation, "Blatt geschützt!"
objAuswertung.Cells(lngZ, 1) = Sheets(intI).Name & " geschützt, Schutz aufheben."
lngZ = lngZ + 1
GoTo nächstesBlatt
End If
Set rngGefundeneZelle = Worksheets(intI).Cells.Find(strSuchbegriff, lookat:=xlPart, LookIn:= _
xlFormulas)
If Not rngGefundeneZelle Is Nothing Then
'erste gefundene Zelle auf dem aktuellen Blatt:
strErsteZelle = rngGefundeneZelle.Address(False, False)
intZähler = intZähler + 1
ReDim Preserve intBlätter(intZähler)
ReDim Preserve strBereiche(intZähler)
intBlätter(intZähler - 1) = intI
strBereiche(intZähler - 1) = strErsteZelle
Do While strAktuelleZelle  strErsteZelle
'nächste gefundene Zelle(n) auf dem aktuellen Blatt
Set rngGefundeneZelle = Worksheets(intI).Cells.FindNext(after:=rngGefundeneZelle)
strAktuelleZelle = rngGefundeneZelle.Address(False, False)
If strErsteZelle  strAktuelleZelle Then
intZähler = intZähler + 1
ReDim Preserve intBlätter(intZähler)
ReDim Preserve strBereiche(intZähler)
intBlätter(intZähler - 1) = intI
strBereiche(intZähler - 1) = strAktuelleZelle
End If
Loop
strAktuelleZelle = ""
strErsteZelle = ""
End If
nächstesBlatt:
Next
Set rngGefundeneZelle = Nothing
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Verknüpfungen in Formeln"
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Blattname"
objAuswertung.Cells(lngZ, 2) = "Zelle"
objAuswertung.Cells(lngZ, 3) = "Formel"
objAuswertung.Cells(lngZ, 4) = "Wert"
objAuswertung.Cells(lngZ, 5) = "Aktion"
objAuswertung.Range(objAuswertung.Cells(lngZ - 1, 1), objAuswertung.Cells(lngZ, 5)).Font.Bold =  _
True
lngZ = lngZ + 1
intLöschZähler = 0
For intN = 0 To intZähler - 1
Sheets(intBlätter(intN)).Select
Range(strBereiche(intN)).Select
objAuswertung.Cells(lngZ, 1) = Sheets(intBlätter(intN)).Name    'Blattname
objAuswertung.Cells(lngZ, 2) = strBereiche(intN)                'Zelle
objAuswertung.Cells(lngZ, 3) = "'" & ActiveCell.Formula         'Formel
objAuswertung.Cells(lngZ, 4) = ActiveCell.Text                       'Wert
objAuswertung.Cells(lngZ, 5) = "erhalten"                       'Aktion
lngZ = lngZ + 1
Next
lngZ = lngZ + 1
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Verknüpfungen in Namen"
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Name"
objAuswertung.Cells(lngZ, 2) = "bezieht sich auf"
objAuswertung.Cells(lngZ, 5) = "Aktion"
objAuswertung.Range(objAuswertung.Cells(lngZ - 1, 1), objAuswertung.Cells(lngZ, 5)).Font.Bold =  _
True
lngZ = lngZ + 1
For Each objName In ActiveWorkbook.Names
If InStr(1, objName.Value, strSuchbegriff) > 1 Then
intZähler = intZähler + 1
objAuswertung.Cells(lngZ, 1) = objName.Name
objAuswertung.Cells(lngZ, 2) = "'" & objName.Value
objAuswertung.Cells(lngZ, 5) = "erhalten"
lngZ = lngZ + 1
End If
Next
If intZähler = 0 Then
MsgBox "Keine Verknüpfung gefunden oder die Blätter sind geschützt.", vbOKOnly +  _
vbInformation, "Fertig!"
Else
MsgBox "Es wurden insgesamt " & intZähler & " Verknüpfung(en) gefunden.", vbOKOnly +  _
vbInformation, "Fertig!"
End If
Set objAuswertung = Nothing
Set objName = Nothing
Workbooks(strAuswertung).Activate
End Sub

Sub Anleitung()
Userform1.Show
End Sub