Verknüpfung entfernen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jürgen!
Kopiere diesen Code in ein allgemeines Modul und führe das Makro "FindLinks" aus!

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Dim iFound As Integer

'
'Quelle unbekannt Wenn jemand diesen Code erkennt und den Author kennt,
' bitte mitteilen! j.ehrensberger@aon.at
'
'Source unknown If someone recognizes this code and knows the Author,
' please tell me! j.ehrensberger@aon.at
'

Private Function CheckDelete(Where As String, What As String)
Dim iResp As Integer
iFound = iFound + 1
iResp = MsgBox("Found a link in " & Where & ":" & Chr(10) & What & Chr(10) & "Shall I delete it?", vbYesNoCancel, "Link Finder")
Select Case iResp
  Case vbCancel
    Application.StatusBar = False
    End
  Case vbYes
    CheckDelete = True
  Case vbNo
    CheckDelete = False
End Select
End Function

Sub FindLinks()
Dim obj As Object, oSheet As Object, oSeries As Object
Dim iOLEfound As Integer, stMsg As String
Dim rCell As Range, rFirst As Range, rToDo As Range
Dim rDone As Range, rAll As Range, rArea As Range
Static LinkString As String

iFound = 0

If IsEmpty(ActiveWorkbook.LinkSources()) Then
  MsgBox "There are no links from this workbook"
  Exit Sub
End If
LinkString = InputBox("Name of file to which links refer?" & _
  Chr(10) & "Do not include path if file is open", Default:=LinkString, _
  Title:="Link Finder")
If LinkString = "" Then Exit Sub

Application.StatusBar = "Looking for links in workbook names"

' first look for names
For Each obj In ActiveWorkbook.Names
  If InStr(obj.RefersTo, LinkString) > 0 Then
    stMsg = ""
    If obj.Visible = False Then stMsg = stMsg & "hidden "
    If CheckDelete(stMsg & "name " & obj.Name, obj.RefersTo) Then obj.Delete
  End If
Next obj

' now scan each sheet in turn
For Each oSheet In ActiveWorkbook.Sheets
  Application.StatusBar = "Looking for links in sheet " & oSheet.Name
  iOLEfound = 0
  If TypeName(oSheet) <> "Module" Then
    For Each obj In oSheet.DrawingObjects

      ' any drawing object could be linked to a macro
      If InStr(obj.OnAction, LinkString) > 0 Then
        If CheckDelete("OnAction of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.OnAction) Then obj.OnAction = ""
      End If

      ' some drawing objects have formula properties
      Select Case TypeName(obj)

        Case "TextBox", "Picture", "Button"
          If InStr(obj.Formula, LinkString) > 0 Then
            If CheckDelete("formula of " & TypeName(obj) & " '" & obj.Name & "' in " & oSheet.Name, obj.Formula) Then obj.Formula = ""
          End If

        Case "OLEObject"
          ' can't get to the formula of an OLEObject - so report at end
          iOLEfound = iOLEfound + 1

        Case "ChartObject"
          For Each oSeries In obj.Chart.SeriesCollection
            If InStr(oSeries.Formula, LinkString) > 0 Then
              If CheckDelete("series " & oSeries.Name & " in Chart " & obj.Name & " on sheet " & oSheet.Name, oSeries.Formula) Then oSeries.Formula = ""
            End If
          Next oSeries
      End Select
    Next
    If TypeName(oSheet) = "Worksheet" Then
      ' look in cell formulae
      Application.ScreenUpdating = False ' otherwise screen flashes
      Set rCell = Nothing
      On Error Resume Next
      Set rCell = oSheet.UsedRange.Find(LinkString, oSheet.UsedRange.Range("A1"), xlFormulas, xlPart, xlByRows, xlNext)
      On Error GoTo 0
      If Not rCell Is Nothing Then
        Set rFirst = rCell
        Set rAll = rCell
        Do
          Set rCell = oSheet.UsedRange.FindNext(rCell)
          Set rAll = Union(rAll, rCell)
        Loop Until rCell.Address = rFirst.Address
        Application.ScreenUpdating = True

        For Each rArea In rAll.Areas
          Set rDone = rArea.Cells(1, 1)
          Set rToDo = rArea.Cells(1, 1)
          Do
            For Each rCell In rArea.Cells
              If Intersect(rDone, rCell) Is Nothing Then
                If rToDo Is Nothing Then
                  Set rToDo = rCell
                ElseIf rCell.FormulaR1C1 = rToDo.Cells(1, 1).FormulaR1C1 Then
                  Set rToDo = Union(rToDo, rCell)
                End If
              End If
            Next rCell
            stMsg = "cell "
            If rToDo.Cells.Count > 1 Then stMsg = "cells "
            If CheckDelete(stMsg & oSheet.Name & "!" & rToDo.Address, rToDo.Range("A1").Formula) Then
              rToDo.Formula = rToDo.Value
            End If
            Set rDone = Union(rDone, rToDo)
            Set rToDo = Nothing
          Loop Until rDone.Address = rArea.Address
        Next rArea
      End If
    ElseIf TypeName(oSheet) = "Chart" Then
      ' look in chart series
      For Each oSeries In oSheet.SeriesCollection
        If InStr(oSeries.Formula, LinkString) > 0 Then
          If CheckDelete("series " & oSeries.Name & " in Chart " & _
            obj.Name, oSeries.Formula) Then oSeries.Formula = ""
        End If
      Next oSeries
    ElseIf TypeName(oSheet) = "DialogSheet" Then
      ' look in on action of dialog frame
      If InStr(oSheet.DialogFrame.OnAction, LinkString) > 0 Then
        If CheckDelete("dialog frame of " & oSheet.Name, oSheet.DialogFrame.OnAction) Then oSheet.DialogFrame.OnAction = ""
      End If
    End If
  End If
  If iOLEfound = 1 Then
    MsgBox "There is an OLE Object on sheet " & oSheet.Name & " which I could not check"
    oSheet.OLEObjects.Select
  ElseIf iOLEfound > 1 Then
    MsgBox "There are " & iOLEfound & " OLE Objects on sheet " & oSheet.Name & " which I could not check"
    oSheet.OLEObjects.Select
  End If
Next oSheet
If iFound = 0 Then MsgBox "No links found to " & LinkString, vbInformation, "Link Finder"
Application.StatusBar = False
End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Verknüpfung entfernen

24 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

24
Beiträge zum Forumthread

Beiträge zu diesem Forumthread