Verknüpfung lösen

Sub SendTab_2() Application.ScreenUpdating = False Dim wks As Worksheet Application.ScreenUpdating = False Set wks = ActiveSheet Worksheets(Range("S1").Value).Copy ActiveWorkbook.SendMail wks.Range("S2").Value, wks.Range("S3").Value ActiveWorkbook.Close savechanges:=False Sheets("Start").Select Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Verknüpfung lösen

15.06.2005 08:13:41

Rene

AW: Teillösung?

15.06.2005 08:15:35

GeorgK

AW: Teillösung?

15.06.2005 08:28:12

Rene

AW: Teillösung?

15.06.2005 15:42:30

GeorgK

Hallo,
ich habe bei meiner weiteren Suche nachfolgenden Makro gefunden, der meine Verknüpfung löst. Kleiner Nachteil noch, es erscheint eine MsgBox. Was muss verändert werden, damit die Verknüpfungen ohne diese Abfrage direkt gelöst werden?
Hier der Makro:


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 " & _
"Verknuepfungen loeschen 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
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

Vielen Dank und Grüße
Georg

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Verknüpfung lösen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread