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 noch 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