Excel-Verknüpfung in vielen Dateien ersetzen?

Hallo,
ich habe einen Ordner mit sehr vielen Excel-Dateien, in welchen sich Verknüpfungen zu einer anderen Datei befinden. Es werden bei diesen Dateien Adressdaten aus einer Datei gezogen.

Leider hatte vor langer Zeit mal Jemand die glorreiche Idee sich diese Adressdatei auf den loaklen Rechner zu kopieren und beim Vorbereiten der neuen Dateien mit der Verknüpfung auf die Adressdatei des lokalen Rechners zu verwenden.

Dadurch enthalten hunderte Excel-Dateien eine falsche Verknüpfung und das Öffnen dauert ewig, weil der Pfad nicht mehr gefunden wird. Der alte Rechner existiert nicht mehr.

Nun würde ich gerne per Makro alle Dateien durchlaufen lassen und den Link \\AlterRechner\Eigene Dateien... durch \\IPdesServers\Pfad ersetzen.

Wie könnte ich da per Makro oder VBS realisieren?

Danke schon mal im Voraus!

Gruß
Torsten

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 192775

Url: https://administrator.de/contentid/192775

Ausgedruckt am: 24.11.2024 um 09:11 Uhr

7 Kommentare

Neuester Kommentar

Wie sind die Dateien in Excel eingebunden ? Als Datenquelle oder als Hyperlink ?

Hallo Softmeister,
die Verknüpfung ist mittels SVERWEIS eingebunden:

=SVERWEIS(WERT(M1);'D:\Pfad\[Datei.xls]Sheet'!$B$1:$F$65536;5;0)  

Im Prinzip würde es mir künftig reichen, wenn die Verknüpfung beim ersten Speichern automatisch entfernt wird und nur der Wert drin bleibt. Die Verknüpfung ist dann ja nicht mehr notwendig.

Das kann ich so lösen:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   ActiveWorkbook.BreakLink Name:="D:\Pfad\Datei.xls", Type:=xlExcelLinks  
   ThisWorkbook.Saved = True
End Sub

Allerdings müsste der Verweis bei den vielen bereits erstellten Vorlagen erst einmal Datei für Datei entfernt werden.
Das wollte ich gerne pro Ordner automatisiert ausführen lassen.

Gruß
Torsten

Hier ein Ansatz für ein Makro:
Die Sub ChangeMultipleFiles sucht sich erst mal alle Excel-Dateien in dem angegebenen Ordner raus um dann die Datei zu öffnen und die entsprechenden Stellen im Dokument zu ersetzen.
Die Funktion ReplacePath sucht in der Arbeitsmappe entsprechende Textstellen und ersetzt sie durch deine Angaben mit dem Aufruf: ReplacePath "D:\Pfad\", "\\Server\".
Zum Schluss speichert das Makro die Datei und schließt sie wieder, dann gehts auf zum nächsten Excel-File.
Du kannst dann noch das ActiveWorkbook.BreakLink mit einbauen.

Function ReplacePath (oldpath As String, newpath As String)
    
   cells.Replace What:=oldpath, Replacement:=newpath, LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        
End Function

Sub ChangeMultipleFiles()
    FOLDER_EXCELFILES = "C:\excelfiles\"  
    Set fso = CreateObject("Scripting.Filesystemobject")  
    Set folderExcelFiles = fso.GetFolder(FOLDER_EXCELFILES)
    
    For Each file In folderExcelFiles.Files
        ext = Right(file.Name, Len(file.Name) - InStrRev(file.Name, "."))  
        If LCase(ext) = "xls" Or LCase(ext) = "xlsx" Then  
            Dim doc As Workbook
            Debug.Print file.Path
            Set doc = Application.Workbooks.Open(file.Path, 0)
            ReplacePath "D:\Pfad\", "\\Server\"  
            doc.Save
            doc.Close
        End If
        
    Next
End Sub

Grüße Uwe

Hallo Uwe,
vielen Dank erst einmal für diese Superlösung.

Ich habe jetzt die Links entfernt. Dazu habe ich noch eine Schleife eingebaut, damit auch alle Sheets durchgegangen werden.

So sieht es jetzt aus:

Function DeleteLink(Anzahl As Integer, Link_1 As String, Link_2 As String, Link_3 As String, Link_4 As String, Link_5 As String, Link_6 As String)

On Error Resume Next

For i = 1 To Anzahl
    ActiveWorkbook.Sheets(i).Activate
    ActiveWorkbook.BreakLink Name:=Link_1, Type:=xlExcelLinks
    ActiveWorkbook.BreakLink Name:=Link_2, Type:=xlExcelLinks
    ActiveWorkbook.BreakLink Name:=Link_3, Type:=xlExcelLinks
    ActiveWorkbook.BreakLink Name:=Link_4, Type:=xlExcelLinks
    ActiveWorkbook.BreakLink Name:=Link_5, Type:=xlExcelLinks
    ActiveWorkbook.BreakLink Name:=Link_5, Type:=xlExcelLinks
Next i
   
ActiveWorkbook.Sheets(1).Activate
   
End Function

Function ReplacePath(OldPath As String, NewPath As String)
    
   Cells.Replace What:=OldPath, Replacement:=NewPath, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
End Function

Sub Links_entfernen()
  
Dim Suche_1 As String, Suche_2 As String, Suche_3 As String, Suche_4 As String, Suche_5 As String, Suche_6 As String
  
Suche_1 = "D:\Pfad1"  
Suche_2 = "D:\Pfad2"  
Suche_3 = "D:\Pfad3"  
Suche_4 = "D:\Pfad4"  
Suche_5 = "D:\Pfad5"  
Suche_6 = "D:\Pfad6"  

FOLDER_EXCELFILES = "D:\Test\"  
    
Set fso = CreateObject("Scripting.Filesystemobject")  
Set folderExcelFiles = fso.GetFolder(FOLDER_EXCELFILES)
  
For Each file In folderExcelFiles.Files
    ext = Right(file.Name, Len(file.Name) - InStrRev(file.Name, "."))  
    
    If LCase(ext) = "xls" Or LCase(ext) = "xlsx" Then  
        Dim doc As Workbook, Anzahl As Integer
        Debug.Print file.Path
        Set doc = Application.Workbooks.Open(file.Path, 0)
        Anzahl = doc.Sheets.Count

        DeleteLink Anzahl, Suche_1, Suche_2, Suche_3, Suche_4, Suche_5, Suche_6
                      
        Application.DisplayAlerts = False
        doc.Save
        doc.Close
        Application.DisplayAlerts = True
    End If
Next

MsgBox "Vorgang beendet."  

End Sub

Das geht natürlich auch Bestens mit Ersetzen, wie du schon schriebst. Ich habe mir einfach beide Varianten in eine leere Arbeitsmappe gepackt.

Danke nochmal !!!

Gruß
Torsten

Hallo Uwe,
es funktioniert jetzt prima. Aber Eines würde mich noch interessieren.

Um den Code knapper zu halten wäre es gut alle SVERWEISE auszulesen und wenn ein bestimmter Dateiname wie z.B. "Test.xls" darin vorkommt diesen SVERWEIS zu entfernen mittels ".BreakLink".

Ist so etwas auch möglich?

Gruß
Torsten

Na sicher geht das mit Regular Expressions kannst du das komfortabel erledigen:
Du musst aber zu deinem VBA Projekt folgenden Verweis hinzufügen (Menü Extras/Verweise...):
Microsoft VBScript Regualr Expressions 5.5

Dim myRegExp, FoundMatch
Set myRegExp = New RegExp
myRegExp.IgnoreCase = True
myRegExp.Pattern = ".*Test.xls.*"  
FoundMatch = myRegExp.Test("c:\Pfad\Test.xls")  

Der Suchpattern wird in der vorletzten Zeile angegeben. In der letzten Zeile wird der Funktion der zu untersuchende String übergeben. Wenn der angegebene Pattern dazu passt gibt die Funktion True(Wahr) zurück, ansonsten False(Falsch).

Tutorials zu Regular Expressions findest du zu Hauf im Netz.

uwe