fehlende Verknüpfung aufspüren

[Glausius]

Hallo,

danke Stefan, aber dein Code bewirkt nur, das der Hinweis nur einmal erscheint und nicht bei jeder falschen Verknüpfung

Mit snb's Ergänzung False beim Workbook.Open wird die Meldung gänzlich unterdrückt, auch eine brauchbare Lösung.
Allerdings komme ich damit immer noch nicht an die auslösende Datei und bei einigen Dutzend eine nach der anderen öffnen zu müssen, um den Fehler zu finden, ist mir doch zu mühselig.

[Gast 123]

Hallo

ich weiss nicht ob ich noch Hilfe anbieten kann mit einem Code von Hajo, Herber Forum
Dieser Code listet alle verknüpften Zellen auf, auch externe Bezüge  Wenn der Bezug fehlt müsste in der Bezug-Adresse "#REF" erscheinen.
Damit habe ich selbst nach Fehlern gesucht . Vielleicht hift das ja weiter den Fehler aufzuspüren.
 
mfg  Gast 123

Code:

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

[snb]

Code:

Sub M_snb()
   with workbooks.open("G:\OF\beispiel.docx",false)
      for each it .LinkSources
         If Dir(it) = "" Then .BreakLink it, 1
      Next
   end with
End Sub

[Glausius]

Hallo snb,

bisher waren alle deine Codevorschläge sehr zielführend (auch in vielen anderen Threads!), aber hier in deinem letzten Code "scheint" etwas zu fehlen!

Wenn ich deinen Vorschlag übernehem, wird von Debugger die Zeile "For each it .LinkSources" angemeckter mit:
Fehler beim Kompilieren:
Erwartet: In
Was fehlt denn da?

[Zwergel]

Hi Günter,

vielleicht so:

Code:

Sub M_snb()
Dim it
  With Workbooks.Open("G:\OF\beispiel.docx", False)
     For Each it In .LinkSources
        If Dir(it) = "" Then .BreakLink it, 1
     Next
  End With
End Sub

[snb]

@Zwergel

[Zwergel]

Danke, aber Thema Blindes Huhn ..... auf Verdacht mit Günters Fehlermeldung.

[snb]

Und natürlich kein docx....   :17:

Code:

Sub M_snb()
   with workbooks.open("G:\OF\beispiel.xlsx",false)
      for each it in .LinkSources
         If Dir(it) = "" Then .BreakLink it, 1
      Next
   end with
End Sub

[Glausius]

Oh je, oh je,

ich habe deinen Vorschlag (snb und Zwergel) jetzt hier so eingefügt:

Code:

Sub Durchsuchen()
    Set oWb = ActiveWorkbook
    strPfad = ThisWorkbook.Path & "\"
    ' strPfad = InputBox("Verzeichnis:", "Welches Verzeichnis?", Default:=CurDir)
    If strPfad = "" Then Exit Sub
    If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
    ReDim strDateien(0)
    'strDateien(0) = Dir(strPfad & "*Finanz*.xls*")           'nur Exceldateien
    strDateien(0) = Dir(strPfad & "*.xls?")                  'nur Exceldateien
    Do Until strDateien(0) = ""
        Select Case strDateien(0)
            Case oWb.Name
            Case Else
                ReDim Preserve strDateien(UBound(strDateien) + 1)
                strDateien(UBound(strDateien)) = strPfad & strDateien(0)
        End Select
        strDateien(0) = Dir
    Loop
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.EnableEvents = False
    For i = 1 To UBound(strDateien)
        With Workbooks.Open(strDateien(i), False) 'False unterdrückt den Hinweis auf falsche Verknüpfungen
            
            For Each it In .LinkSources
                If Dir(it) = "" Then .BreakLink it, 1
            Next
            
            z = Left(ActiveWorkbook.Name, 4)
            On Error GoTo 0
            For Each ws In ActiveWorkbook.Worksheets
                If Left(ws.Name, 2) <> "AW" And _
                            ws.Name <> "Konten" And _
                   Left(ws.Name, 1) <> "." And _
                            ws.Name <> "Steuer" And _
                   Left(ws.Name, 3) <> "Neu" And _
                   Left(ws.Name, 5) <> "Anlei" Then       'Kontenblätter von der Suche ausschließen
                    With ws.Range(ws.Cells(4, SuchSpalte(1)), ws.Cells(65536, SuchSpalte(1)))
                        If IsNumeric(SuchKrit(1)) Then
                            Set c = .Find(CDbl(SuchKrit(1)), LookAt:=xlWhole, LookIn:=xlFormulas)
                        Else
                            Set c = .Find(SuchKrit(1), LookAt:=xlPart, LookIn:=xlValues)
                        End If
                        If Not c Is Nothing Then
                            firstAddress = c.Address
                            Do
                                x = c.Row
                                If k = 1 Then
                                    Auslesen
                                Else
                                    merker = 0
                                    For p = 2 To k
                                        'If Sheets(ws.Name).Cells(x, SuchSpalte(p)) = SuchKrit(p) Then
                                        If InStr(1, Sheets(ws.Name).Cells(x, SuchSpalte(p)), SuchKrit(p)) Then
                                            merker = merker + 1
                                        End If
                                    Next p
                                    If merker = k - 1 Then Auslesen
                                End If
                                If j > 1000 Then Exit For
                                Set c = .FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
                    End With
                End If
            Next
            Application.DisplayAlerts = False
            ActiveWorkbook.Close
        End With
    Next i
    Application.EnableEvents = True
    'Application.ScreenUpdating = False
    If j > 0 Then Sheets("Suche").Range("A6").Resize(j, 14) = Erg
    Application.ScreenUpdating = True
    Erase Erg()
    Set c = Nothing
End Sub

und nun meckert er it als nicht deklarierte Variable an!
Wie muss ich das deklarieren?

@gast123
danke hier deinen Hinweis, den Code von Hajp habe ich auch und kann damit Verknüpfungen in einer Datei aufspüren, aber dazu muss ich eben erst wissen, in welcher Datei ich suchen muss - und das ist hier noch iicht gelöst.

[Kuwer]

Hallo Günter,

und nun meckert er it als nicht deklarierte Variable an!
Wie muss ich das deklarieren?

nicht nur it ist nicht deklariert, sondern alles andere auch (nicht). Da wird es einfacher sein, Option Explicit auszukommentieren.

Gruß Uwe