AW: Verknüfung automatisch ändern (variabler Pfad)
14.08.2010 17:47:05
fcs
Hallo Gordon,
hier mal zwei Beispiele zur Linkanpassung. 1. mit Auswahldialog, 2. direkt in 2. Datei
Gruß
Franz
Sub LinkAnpassen()
Dim sLinkAktiv As String, sLinkDatei As String, vLinks
Dim sMsgText As String, vAuswahl
Dim wbAktiv As Workbook, wbDatei2 As Workbook
Set wbAktiv = ActiveWorkbook
'Linkliste in der aktiven Datei für Inputbox erstellen
sLinkAktiv = Link_Liste(wb:=wbAktiv, bIndex:=False)
'2. Datei öffnen
vAuswahl = Application.Dialogs(xlDialogOpen).Show
If vAuswahl = True Then
Set wbDatei2 = ActiveWorkbook
'Linkliste in der geöffneter Datei für Inputbox erstellen
sLinkDatei = Link_Liste(wb:=wbDatei2)
'Prompt für Inputbox erstellen
sMsgText = wbAktiv.Name & vbNewLine & sLinkAktiv & vbNewLine & vbNewLine
sMsgText = sMsgText & wbDatei2.Name & vbNewLine & sLinkDatei & vbNewLine & vbNewLine
sMsgText = sMsgText & "Welchen Link (Nr.) in geöffneter Datei anpassen?"
'zu ändernden Link auswählen"
vAuswahl = InputBox(sMsgText, "Link - Anpassen", Default:=1)
If vAuswahl "" And IsNumeric(vAuswahl) Then
vLinks = wbDatei2.LinkSources(Type:=xlExcelLinks)
wbDatei2.ChangeLink Name:=vLinks(CLng(vAuswahl)), NewName:=wbAktiv.FullName
Application.Calculate
End If
wbDatei2.Close savechanges:=True
End If
End Sub
Sub LinkAnpassen_direkt() 'wenn 2. Datei fest und immer nur ein Link vorhanden
Dim vLinks, sPath As String, sFile As String
Dim wbAktiv As Workbook, wbDatei2 As Workbook
On Error GoTo Fehler
Set wbAktiv = ActiveWorkbook
sPath = "C:\Users\Public\Test\01\Test01"
sFile = "TestData_102.xls"
'2. Datei öffnen
Application.ScreenUpdating = False
Set wbDatei2 = Workbooks.Open(Filename:=sPath & Application.PathSeparator & sFile)
'Excel-Linkliste in 2. Datei
vLinks = wbDatei2.LinkSources(Type:=xlExcelLinks)
If IsArray(vLinks) Then
wbDatei2.ChangeLink Name:=vLinks(1), NewName:=wbAktiv.FullName
Application.Calculate
Else
MsgBox "in Datei """ & wbDatei2.Name & """ sind keine Links vorhanden"
End If
wbDatei2.Close savechanges:=True
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbNewLine & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub
Public Function Link_Liste(wb As Workbook, Optional bIndex As Boolean = True) As String
'Liste der Links zu Exceldateien als Liste Text-Liste erstellen
Dim vLink As Variant, iIndex&
For Each vLink In wb.LinkSources(Type:=xlExcelLinks)
iIndex = iIndex + 1
Link_Liste = IIf(bIndex, iIndex & " ", "") & vLink & vbNewLine
Next
End Function