AW: Diese datei enthält Verknüpfungen zu anderen Daten
20.11.2016 00:16:45
Piet
Hallo David,
privat benutze ich ein Makro von Hajo um Verknüpfungen aufzuspüren. s. unten.
Sein Makro erstellt eine komplette Liste über alle Formeln in der Arbeitsmappe.
mfg Piet
Option Explicit 'Verknüpfungen Hajo
Sub Verknuepfte_Zellen()
'* H. Ziplies *
'* 24.08.08 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
On Error GoTo Fehler1 ' Fehlerbehandlung ausschalten
Dim RaZelle As Range ' Variable für aktuelle Zelle
Dim ByMldg As Byte ' Variable Meldung
Dim WsSh As Worksheet ' Variable Tabelle
Dim ObZelle As Object ' Variable für Namen
For Each WsSh In Worksheets ' Schleife über alle Tabellen der Datei
' Prüfen ob Tabelle schon vorhanden
If InStr(WsSh.Name, "Verknüpfungen") > 0 Then
ByMldg = MsgBox("Eine Tabelle mit dem Namen " _
& "Verknüfungen ist schon vorhanden, sollen die " _
& "Daten gelöscht werden", vbYesNo + vbQuestion, _
"Löschabfrage ?", "", 0)
If ByMldg = 6 Then ' Ja wurde gedrückt
' Zellen komplett löschen,
' da schon bestimmte Formate eingestellt
WsSh.Cells.Delete
' Kennzeichnen dass Tabelle schon vorhanden
ByMldg = 45
' Schleife verlasse, da Tabelle gefunden
Exit For
Else
Exit Sub
End If
End If
Next WsSh
Application.ScreenUpdating = False ' Bildschirmaktualisierung ausschalten
Application.EnableEvents = False ' Reaktion Eingabe abschalten
If ByMldg 45 Then ' Tabelle anlegen falls nicht vorhanden
' Anlegen hinter der letzten Tabelle ubnd Namen geben
Sheets.add(After:=Sheets(Sheets.Count)).Name = "Verknüpfungen"
With ActiveWindow
.SplitRow = 2
.FreezePanes = True
End With
End If
With Worksheets("Verknüpfungen")
' Überschriftszeilen
' Formel mit Ergebnis Fehler
.Cells(1, 1) = "Formel mit Ergebnis Fehler"
.Cells(2, 1) = "Zelle"
.Cells(2, 2) = "Tabelle"
.Cells(2, 3) = "Formel"
' Formel zu anderen Arbeitsmappe
.Cells(1, 5) = "Formel zu anderen Arbeitsmappe"
.Cells(2, 5) = "Zelle"
.Cells(2, 6) = "Tabelle"
.Cells(2, 7) = "Formel"
' Formel zu anderen Tabellen in dieser Arbeitsmappe
.Cells(1, 9) = "andere Tabelle"
.Cells(2, 9) = "Zelle"
.Cells(2, 10) = "Tabelle"
.Cells(2, 11) = "Formel"
' restliche Formel
.Cells(1, 13) = "Rest"
.Cells(2, 13) = "Zelle"
.Cells(2, 14) = "Tabelle"
.Cells(2, 15) = "Formel"
' definierte Namen in dieser Arbeitsmappe
.Cells(1, 17) = "definierte Namen"
.Cells(2, 17) = "Name"
.Cells(2, 18) = "Zelle"
.Cells(2, 19) = "Tabelle"
Rows("1:2").Font.Bold = True
For Each WsSh In Worksheets ' Schleife über alle Tabellen
If WsSh.Name "Verknüpfungen" Then
' Schutz aufheben falls vorhanden
' WsSh.Unprotect "Passwort"
On Error Resume Next
Set RaZelle = WsSh.UsedRange.SpecialCells(xlCellTypeFormulas)
Set RaZelle = Nothing
If Err.Number = 0 Then
On Error GoTo 0
' Schleife über den benuzten Bereich mit Formel
For Each RaZelle In WsSh.UsedRange.SpecialCells(xlCellTypeFormulas)
' Formeln mit Fehler
If IsError(RaZelle.Value) Then
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) _
= RaZelle.Address(0, 0)
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2) _
= CStr(WsSh.Name)
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3) _
= "'" & RaZelle.FormulaLocal
' Formel zu anderer Arbeitsmappe
ElseIf InStr(RaZelle.Formula, ":\") 0 Then
.Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 1, 5) _
= RaZelle.Address(0, 0)
.Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 6) _
= CStr(WsSh.Name)
.Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 7) _
= "'" & RaZelle.FormulaLocal
' Formel zu andere Tabelle
ElseIf InStr(RaZelle.Formula, "!") > 1 Then
.Cells(.Cells(.Rows.Count, 9).End(xlUp).Row + 1, 9) _
= RaZelle.Address(0, 0)
.Cells(.Cells(.Rows.Count, 9).End(xlUp).Row, 10) _
= CStr(WsSh.Name)
.Cells(.Cells(.Rows.Count, 9).End(xlUp).Row, 11) _
= "'" & RaZelle.FormulaLocal
Else ' restliche Formeln
.Cells(.Cells(.Rows.Count, 13).End(xlUp).Row + 1, 13) _
= RaZelle.Address(0, 0)
.Cells(.Cells(.Rows.Count, 13).End(xlUp).Row, 14) _
= CStr(WsSh.Name)
.Cells(.Cells(.Rows.Count, 13).End(xlUp).Row, 15) _
= "'" & RaZelle.FormulaLocal
End If
Next RaZelle
End If
On Error GoTo 0 ' Fehlerbehandlung einschalten
End If
' WsSh.Protect "Passwort" ' Schutz wieder setzen
Next WsSh
' Programmteil Namen auslesen
' Schleife über alle Namen der Datei
For Each ObZelle In ActiveWorkbook.Names
.Cells(.Cells(.Rows.Count, 17).End(xlUp).Row + 1, 17) _
= ObZelle.Name
With .Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 18)
If InStr(ObZelle, "REF") 0 Then
.Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
.Font.Bold = True
.Font.ColorIndex = 3
ElseIf InStr(ObZelle, "\") 0 Then
.Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
.Font.Bold = True
.Font.ColorIndex = 4
Else
.Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
End If
End With
If InStr(ObZelle.RefersTo, "!") > 0 Then
.Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 19) _
= Application.WorksheetFunction.Substitute(Mid(ObZelle, _
2, InStr(ObZelle, "!") - 2), "'", "")
Else
.Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 19) _
= ObZelle.RefersTo
End If
Next
.Range("B:C,F:G,J:K,N:O, R:S").EntireColumn.AutoFit
' Überschriftszeilen
' Formel mit Ergebnis Fehler
.Cells(1, "A") = "Zellen mit Ergebnis Error"
' Formel zu anderen Arbeitsmappe
.Cells(1, "E") = "Formeln zu anderen Arbeitsmappen"
' Formel zu anderen Tabellen in dieser Arbeitsmappe
.Cells(1, "I") = "Formeln zu anderen Tabellen"
' restliche Formel
.Cells(1, "M") = "restliche Formeln"
' definierte Namen in dieser Arbeitsmappe
.Cells(1, "O") = "Namen in dieser Arbeitsmappe"
End With
Fehler1:
On Error GoTo 0 ' Fehlerbehandlung eimschalten
If Err 0 Then MsgBox "Es ist ein Fehler aufgetreten!"
Application.ScreenUpdating = True ' Bildschirmaktualisierung einschalten
Application.EnableEvents = True ' Reaktion Eingabe einschalten
End Sub