Probleme mit einer xla

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 suchen"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Temporary:=True)
neuerEintrag.Caption = "&Verknüpfungen finden und bearbeiten"
neuerEintrag.OnAction = "Suchen"
Set neuerEintrag = neuesMenü.Controls.Add(Type:=msoControlButton, Temporary:=True)
neuerEintrag.Caption = "&Hilfe"
neuerEintrag.OnAction = "Hilfe"
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()
On Error Resume Next
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 = "Protokoll"
Set objAuswertung = Workbooks(ActiveWorkbook.Name).Sheets("Protokoll")
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) = "Zellen, in denen Formeln stehen oder etwas, was danach aussieht, wurden wie folgt bearbeitet."
lngZ = lngZ + 1
objAuswertung.Cells(lngZ, 1) = "Blattname"
objAuswertung.Cells(lngZ, 2) = "Zelle"
objAuswertung.Cells(lngZ, 3) = "Formel oder Verweis"
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
'##########                 NEU by Ray Stein                 ###########
'Problem:
'Bei Rückgabe von tbVerweis in Zelle bleibt die eingegebene Formel nicht
'erhalten sondern nur der Wert. Statt "+A1" steht in der Zelle nur der Wert aus Zelle A1
Rückgabewert = 0
On Error Resume Next
'frm Füllen
frmVerknüpfg.tbBlatt.Text = "" & Sheets(intBlätter(intN)).Name
frmVerknüpfg.tbZelle.Text = "" & strBereiche(intN)
frmVerknüpfg.tbWert.Text = "" & Worksheets("" & Sheets(intBlätter(intN)).Name).Range("" & strBereiche(intN)).Value
frmVerknüpfg.tbVerknüpfg.Text = "" & ActiveCell.Formula
If frmVerknüpfg.tbVerknüpfg = "" Then frmVerknüpfg.cmdEnde.Enabled = False
frmVerknüpfg.Show
frmVerknüpfg.cmdWeiter.SetFocus
'Rückgabe:
'1 = Verknüpfung korrigieren
'2 = Verknüpfung löschen und durch deren Wert ersetzt werden?"
'3 = weiter ohne alles
If Rückgabewert = 4 Then
Exit Sub
End If
If Rückgabewert = 1 Then
On Error GoTo zError
Worksheets("" & Sheets(intBlätter(intN)).Name).Range("" & strBereiche(intN)) = tbVerweis 'Rückgabe in aktive Zelle
'################# ERROR ##################################################################
'ERROR: in Zelle bleibt die zurückgegebene Formel nicht erhalten sondern nur der Wert. Statt "+A1" steht in der Zelle nur der Wert aus Zelle A1
'####################### ERROR #############################################################
'Range("A1").Select
'Selection.NumberFormat = "General"
'protokoll erstellen
Range(strBereiche(intN)) = Range(strBereiche(intN))
objAuswertung.Cells(lngZ, 5) = "nicht gelöscht, aber verändert"    'Aktion
objAuswertung.Cells(lngZ, 6) = tbVerweis
intLöschZähler = intLöschZähler + 1
GoTo zweiter
zError:
MsgBox "Nicht zu verarbeitende Veränderung der angezeigten Daten", vbCritical, "RayStein Info"
End If
zweiter:
'old: If intAbfrage = vbYes Then
If Rückgabewert = 2 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 Hilfe()
HelpCenter.Show
Application.Run "LautAn"
End Sub