AW: Bezüge löschen
18.10.2005 21:17:39
Hajo_Zi
Hallo Klaus,
ich muß Feierabend machen ich bin nicht mehr gut drauf. der bisher gepostete Code ist falsch.
Option Explicit
Sub Verknüpfte_Zellen()
'* H. Ziplies *
'* 22.08.03, 24.04.04; 31.07.05 *
'* erstellt von Hajo.Ziplies@web.de *
'* <a href="http://home.media-n.de/ziplies/">http://home.media-n.de/ziplies/</a> *
' Verknüpfungen auflisten
Dim RaZelle As Range
Dim ByMldg As Byte
Dim Sh As Worksheet
Dim ObZelle As Object
For Each Sh In Worksheets
If InStr(Sh.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
Sh.Cells.Delete
ByMldg = 45
Exit For
Else
Exit Sub
End If
End If
Next Sh
If ByMldg <> 45 Then
Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Verknüpfungen"
End If
With Worksheets("Verknüpfungen")
' Verknpüfungen
.Cells(1, 1) = "Zelle"
.Cells(1, 2) = "Tabelle"
.Cells(1, 3) = "Formel"
For Each Sh In Worksheets
If Sh.Name <> "Verknüpfungen" Then
Sh.Unprotect ' .unprotect "Passwort"
For Each RaZelle In Sh.UsedRange
If RaZelle.HasFormula And InStr(RaZelle.Formula, ":\") > 1 Then
.Cells(.Range("A65536").End(xlUp).Row + 1, 1) = RaZelle.Address(0, 0)
.Cells(.Range("A65536").End(xlUp).Row, 2) = Sh.Name
.Cells(.Range("A65536").End(xlUp).Row, 3) = "'" & RaZelle.Formula
End If
Next RaZelle
Sh.Protect ' .Protect "Passwort"
End If
Next Sh
' Namen
.Cells(1, 5) = "Name"
.Cells(1, 6) = "Bezug"
For Each ObZelle In ActiveWorkbook.Names
.Cells(.Range("E65536").End(xlUp).Row + 1, 5) = ObZelle.Name
With .Cells(.Range("E65536").End(xlUp).Row, 6)
If InStr(ObZelle, "REF") <> 0 Then
.Value = ObZelle '"Fehlerhaft"
.Font.Bold = True
.Font.ColorIndex = 3
ElseIf InStr(ObZelle, "\") <> 0 Then
.Value = ObZelle
.Font.Bold = True
.Font.ColorIndex = 4
Else
.Value = Mid(ObZelle, 2)
End If
End With
Next
End With
End Sub
Ich habe in Deiner Datei aber keine Verknüpfungen gefunden und auch die Namen beziehen sich nicht auf andere Dateien.
Gruß Hajo
"Wer Rechtschreibfehler findet, darf sie behalten!"