ich hab ein Problem mit dem Aufruf von Dateien, welche mit anderen verlinkt sind. Aufgabe des folgenden Programms soll sein, in einem bestimmten Pfad alle vorhanden Exceldateien aufzurufen und in diesen nach bestimmten Verknüpfungen zu suchen, um letztendlich einige von diesen umzuschreiben. Ich muss nämlich eine sehr große Menge Dateien in ein komplett anderes Pfadsystem schaufeln und dazu ist das wichtig.
Option Explicit
Dim z As Long
' Rekursive Prozedur
Public Sub xDirFile(xpath As String)
Dim xa As Long
Dim xDir As String
ReDim xt(0) As String
Dim xi As Long
Dim xAc As String
Dim wb As Workbook
Dim aLinks
Dim i As Integer
Dim newlink As String
' Zulassen von allen Formen von Dateien
xDir = Dir(xpath & "\*.*", vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)
xa = 0
If Len(xDir) > 0 Then
xt(0) = xDir
End If
Do While Len(xDir) > 0
xDir = Dir
If Len(xDir) > 0 And Not xDir = "." And Not xDir = ".." Then
xa& = xa& + 1
ReDim Preserve xt(xa)
xt(xa) = xDir
End If
Loop
On Error GoTo Schleife
For xi& = 0 To xa&
If Len(xt(xi)) = 0 Then
Exit For
ElseIf Not xt(xi) = "." And Not xt(xi) = ".." Then
If Len(Dir$(xpath$ & "\" & xt$(xi&), vbNormal Or vbReadOnly Or vbHidden _
Or vbSystem Or vbVolume Or vbDirectory Or vbArchive)) > 0 Then
If Not (GetAttr(xpath & "\" & xt(xi)) And vbDirectory) = vbDirectory Then
If UCase(Right(xt(xi), 3)) = "XLS" Then
' die "0" bedeutet, dass die Frage nach der Aktualisierung
' von Verlinkungen verneint wird
Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
aLinks = wb.LinkSources(xlExcelLinks)
If Not IsEmpty(aLinks) Then
For i = 1 To UBound(aLinks)
' Link ändern
' -> Replace ist die Ersetzfunktion
' -> vbTextCompare -> Link kann klein oder groß geschrieben sein
newlink = Replace(aLinks(i), "C:\daten\test", "E:\Bericht\2007\", _
, , vbTextCompare)
wb.ChangeLink aLinks(i), newlink
wb.Save
Next i
End If
wb.Close savechanges:=False
Set wb = Nothing
End If
Else
Call xDirFile(xpath & "\" & xt(xi))
End If
End If
End If
Schleife:
Next xi&
On Error GoTo 0
End Sub
' Aufrufprozedur zum Start
Sub test()
Application.ScreenUpdating = False
' der hier angegebene Pfad wird mit all seinen Unterpfaden durchgegangen
xDirFile "E:\Bericht"
Application.ScreenUpdating = True
End Sub
Wenn durch den Quelltext die Dateien aufgerufen werden, sollen die Nachfragen nach der Aktualisierung von Verknüpfungen verneint werden. Das geschieht eigentlich durch die 0 in
Set wb = Workbooks.Open(xpath & "\" & xt(xi), 0)
Nun kommt es aber dennoch beim Durchlauf des Programms zu einer (etwas anderen Darstellung) genau derselben Frage.
Kann mir vielleicht jemand verraten, wie ich diese ebenfalls unterbinden kann, denn sonst muss ich bei jeder verlinkten Datei Abbrechen klicken und dafür handelt es sich um zu viele Dateien?
Eine weitere Frage ist, dass das Prinzip des TextCompare nicht funktioniert und mir eben nicht alle Teile, egal ob groß oder klein geschrieben, ersetzt werden. Weiß jemand, was daran falsch ist?
Gruss
Andreas