Verlorene Verlinkungen

Hallo!
vielleicht könnt Ihr mir helfen. Durch Änderung eines Dateipfades sind alle Dateien fehlerhaft.
Nun möchte ich mit VBA alle Dateien öffnen, Pfad ändern, speichern und schließen. --> Das Funktioniert. (siehe code)
Problem: Leider befinden sich die Daten auf einer Arbeitsmappe welche versteckt (2 - xlSheetVeryHidden) und das VBA Projekt noch PW geschützt ist.
Hat jemand eine Idee?

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 = Worksheets("Tabelle1").Cells(1, 1).Value
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) = "xlsm" Or LCase(ext) = "xlsx" Then
Dim doc As Workbook
Debug.Print file.Path
Set doc = Application.Workbooks.Open(file.Path, 0)
ReplacePath "L:\Order Management\00 - Orders I Bestellungen I Objednavky I Narocila\ _
_Formular\", "L:\VID\00 - Orders I Bestellungen I Objednavky I Narocila\_Formular\"
doc.Save
doc.Close
End If
Next
End Sub

LG
Christoph

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Christoph,
teste mal:

Option Explicit

Public Sub ChangeMultipleFiles()

    Dim strFolder As String, strFilename As String
    Dim objWorkbook As Workbook

    With Application
        .AskToUpdateLinks = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    strFolder = Worksheets("Tabelle1").Cells(1, 1).Value

    If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"

    strFilename = Dir$(strFolder & "*.xls*")

    Do Until strFilename = vbNullString

        Set objWorkbook = Workbooks.Open(Filename:=strFolder & strFilename, UpdateLinks:=0)

        Call ReplacePath("L:\Order Management\00 - Orders I Bestellungen I Objednavky I Narocila\_Formular\", _
            "L:\VID\00 - Orders I Bestellungen I Objednavky I Narocila\_Formular\", objWorkbook)

        Call objWorkbook.Close(SaveChanges:=True)

        strFilename = Dir$

    Loop

    Set objWorkbook = Nothing

    With Application
        .AskToUpdateLinks = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Private Sub ReplacePath(oldpath As String, newpath As String, objWorkbook As Workbook)

    Dim objWorksheet As Worksheet

    For Each objWorksheet In objWorkbook.Worksheets

        objWorksheet.Cells.Replace What:=oldpath, Replacement:=newpath, LookAt:=xlPart

    Next
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread