title image


Smiley Re: verknüpfungen finden (die normalen methoden funktionieren nicht...)
Teste mal folgendes Makro!



Gruß Stefan



Sub VerknuepfungenLoeschen()

Dim varLinks

Dim lngLinkCount As Long

Dim i As Long

Dim strLinkedFile As String

Dim lngChrPos As Long

Dim objRefName As Name

Dim strExtRef As String

Dim objWSh As Worksheet

Dim LinkRange As Range

Dim ar As Range



If MsgBox("Wollen Sie alle externen " & _

"Verknüpfungen löschen und durch die " & _

"entsprechenden Werte ersetzen?", vbYesNo) _

= vbYes Then

varLinks = ActiveWorkbook.LinkSources(xlExcelLinks)

If IsArray(varLinks) Then

lngLinkCount = UBound(varLinks)

For i = 1 To lngLinkCount

strLinkedFile = varLinks(i)

Do

lngChrPos = InStr(1, strLinkedFile, "\")

strLinkedFile = _

Right(strLinkedFile, _

Len(strLinkedFile) - lngChrPos)

Loop Until lngChrPos = 0

For Each objWSh In ActiveWorkbook.Worksheets

Set LinkRange = GetLinkRange(objWSh, _

strLinkedFile)

If Not LinkRange Is Nothing Then

For Each ar In LinkRange.Areas

' MsgBox ar.AddressLocal

ar.Value = ar.Value2

Next ar

End If

Next objWSh

Next i

End If

For Each objRefName In ActiveWorkbook.Names

If InStr(1, objRefName.RefersTo, ".xl") > 0 Then

strExtRef = objRefName.Name

For Each objWSh In ActiveWorkbook.Worksheets

Set LinkRange = GetLinkRange(objWSh, strExtRef)

If Not LinkRange Is Nothing Then

For Each ar In LinkRange.Areas

ar.Value = ar.Value2

Next ar

End If

Next objWSh

objRefName.Delete

End If

Next objRefName

End If

End Sub



Function GetLinkRange(objSheet As Worksheet, _

strSearchFor As String) As Range

Dim TempCell As Range

Dim TempRange As Range

Dim strTempAdr As String



With objSheet.UsedRange

Set TempCell = _

.Find(What:=strSearchFor, LookIn:=xlFormulas, LookAt:=xlPart)

If Not TempCell Is Nothing Then

strTempAdr = TempCell.Address

Set TempRange = TempCell

Do

Set TempCell = .FindNext(TempCell)

If Not TempCell Is Nothing Then

Set TempRange = Application.Union(TempRange, TempCell)

End If

Loop While _

Not TempCell Is Nothing _

And TempCell.Address <> strTempAdr

End If

End With

Set GetLinkRange = TempRange

End Function







geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: