Sub Dokument_oeffnen()
Dim alterPfad As String
Dim neuerPfad As String
Dim dokuPfad As String
Dim i As Integer
Dim x As Integer
Dim links As Integer
Dim appwd As Object
Dim fld, file
Dim fso As Object
Dim objFld As Object
Dim objSubFld As Object
Dim objFiles As Object
dokuPfad = ""
alterPfad = ""
neuerPfad = ""
x = 1
dokuPfad = Range("E4").Value
alterPfad = Range("F4").Value
neuerPfad = Range("G4").Value
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFld = fso.getfolder(dokuPfad)
Set objSubFld = objFld.SubFolders
For Each fld In objSubFld
Set objFiles = fld.Files
For Each file In objFiles
If InStrRev(file.Path, ".xls") >= 1 Then
Application.Workbooks.Open file.Path
Do While x <= Worksheets.Count
Worksheets(x).Select
ActiveSheet.UsedRange.Select
i = 1
Do While i <= Selection.Hyperlinks.Count
If Selection.Hyperlinks(i).Address = alterPfad Then
Selection.Hyperlinks(i).Address = neuerPfad
i = i + 1
Else
i = i + 1
End If
Loop
Cells.Replace What:=alterPfad, Replacement:=neuerPfad, LookAt:=xlWhole, _
SearchOrder:=xlByRows
x = x + 1
Range("A1").Select
Loop
Worksheets(1).Select
ActiveWorkbook.Save
ActiveWorkbook.Close
ElseIf InStrRev(file.Path, ".doc") >= 1 Then
Set appwd = CreateObject("Word.Application")
appwd.Visible = True
appwd.documents.Open file.Path
i = 1
Do While i <= appwd.ActiveDocument.Hyperlinks.Count
If appwd.ActiveDocument.Hyperlinks(i).Address = alterPfad Then
appwd.ActiveDocument.Hyperlinks(i).Address = neuerPfad
i = i + 1
Else
i = i + 1
End If
Loop
appwd.Selection.Find.Replacement.ClearFormatting
With appwd.Selection.Find
.Text = alterPfad
.Replacement.Text = neuerPfad
.Forward = True
.Wrap = wdFindContinue
End With
appwd.Selection.Find.Execute Replace:=wdReplaceAll
appwd.documents(file.Path).Save
appwd.documents(file.Path).Close
appwd.Quit
Set appwd = Nothing
End If
Next
Next
End Sub