Hallo zusammen,

ich bin Azubi bei einer IT-Firma und muss gerade ein Excel-VBA-Makro schreiben. Bin absolut nicht bewandert was VBA angeht und hoffe auf Hilfe!

Es geht um ein Programm, bei dem man ein Verzeichnis angibt und dieses dann vollständig (d.h. mit Unterordnern) nach Word- und Excel-Dateien durchsucht werden soll. Anschließend sollen alle Dateien nach Hyperlinks durchsucht werden und diese durch Neue ersetzt werden (das Öffnen/Ersetzen/Schließen habe ich).
Mein Problem momentan: Ich habe mit Unterstützung diese Forums eine Durchsuchung der Ordner geschrieben, welche allerdings momentan nur Excel-Dateien bearbeitet und die Word-Dokumente unverändert zurücklässt. Bitte hier um Unterstützung.

Außerdem wäre es nett, wenn jemand eine Anregung hätte, wie ich die Hyperlinks nur teilweise ersetzen kann. D.h. es wird nur der Teil einer Ordnerstruktur angegeben, der sich verändern soll (z.B. c:\desktop\bla in c:\desktop\blub). Nun soll in allen Dateien, die den entsprechenden alten Teil des Pfades als Hyperlink enthalten, der Teil der sich verändert ersetzt werden. Beispiel: c:\desktop\bla\blub\test.xlsm in c:\desktop\blub\blub\test.xlsm (aber nur mit den Angaben aus dem vorigen Beispiel). Hoffe das ist verständlich :S

Hier noch mein bisheriger Code:

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