Guten Tag, 

ich hätte mal wieder ein anliegen. Ich hab ein Makro welches nicht nur die Dateien im gewählten Ordner bearbeitet soll, sondern auch alle unterordner mit einbezieht. Es handelt sich dabei um den Unten eingefügten Code. Ich hatte es mal umgeschrieben und es rekursiv durch alle Ordner laufen lasse, dies hat leider zuviel Arbeitsspeicher benötigt und hat nicht mehr funktioniert. Kennt jemand eine Alternative? Da ich mich mit VBA-Kaum auskenne wäre es auch nett, wen ihr mir verratet wo der Code hinkommt. 

MFG Sven

Option Explicit

Sub BilderKommentarundHyperlink()

Dim xFDObject As FileDialog
Dim xStrPath, xStrPicPath As String

Dim XRgName As Range
Dim XRgKurzbezeichnung As Range
Dim XRgBezeichnung As Range

Dim xRg As Range
Dim searchTerm1 As String
Dim split_filename As String


Dim cmt As Comment
Dim cy As Long

Dim file As Variant
Dim T As Variant
Dim T1 As Variant

Dim FileSystemObject As Object

Application.ScreenUpdating = False


'Ordner mit den Bildern
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
Set xFDObject = Application.FileDialog(msoFileDialogFolderPicker)
With xFDObject
    .Title = "Bitte den Ordner mit den Bildern wählen:"
    .InitialFileName = Application.ActiveWorkbook.Path
    .Show
    .AllowMultiSelect = False
End With

'Nur wenn ein Ordner angewählt wurde
If xFDObject.SelectedItems.Count > 0 Then
    xStrPath = xFDObject.SelectedItems.Item(1)
Else
    MsgBox "Keinen Ordner Ausgewählt", vbInformation Or vbOKOnly, "/ Information"
    Exit Sub
End If


'Hier wird die Hyperlink und Bild hinterlegt
Set XRgBezeichnung = Application.InputBox("Bitte den Bereich für die Bilder auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgBezeichnung Is Nothing Then Exit Sub


'Hier wird der Name ausgewählt
Set XRgName = Application.InputBox("Bitte den Bereich mit dem Namen wählen:", "Bitte die Spalte anwählen", Type:=8)
If XRgName Is Nothing Then Exit Sub

'Hier wird die KKurzbezeichnung ausgewählt
Set XRgKurzbezeichnung = Application.InputBox("Bitte den Bereich mit der Kurzbeschreibung auswählen:", "Bitte die Spalte wählen", Type:=8)
If XRgKurzbezeichnung Is Nothing Then Exit Sub


' Lösche alle Kommentare und Hyperlinks im ausgewählten Bereich
For cy = 1 To XRgBezeichnung.Count
    If XRgBezeichnung(cy, 1).Value2 = "" Then Exit For
    If Not XRgBezeichnung(cy, 1).Comment Is Nothing Then XRgBezeichnung(cy, 1).Comment.Delete
    If Not XRgBezeichnung(cy, 1).Hyperlinks Is Nothing Then XRgBezeichnung(cy, 1).Hyperlinks.Delete
Next


'Alle Datein im Ordner durchlaufen
    For Each file In FileSystemObject.GetFolder(xStrPath).Files
    
    'String vom Dateinamen säubern
        If UBound(Split(file.Name, "_")) = 4 Then
        split_filename = Split(file.Name, "_")(2) & ", " & Split(file.Name, "_")(4) & ", " & Split(file.Name, "_")(3)
        For Each T In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
            split_filename = Replace(split_filename, T, "")
        Next

        
        ' Überprüfen, ob der Dateiname "thumbs.dp" enthält
        If InStr(file.Name, "thumbs.dp") = 0 Then
        
        cy = 1
        Do While XRgName(cy, 1).Value2 <> ""

    
        'String der Beschreibung säubern
        searchTerm1 = XRgName(cy, 1) & XRgKurzbezeichnung(cy, 1) & XRgBezeichnung(cy, 1)
        For Each T1 In Array(" ", ",", "-", "%", "&", "/", "(", ")", "\", """", ":", ";", "+", ".png")
            searchTerm1 = Replace(searchTerm1, T1, "")
        Next
        
        'Beide miteinander vergleichen
        If searchTerm1 = split_filename Then
            
        'Hyperlink zur Datei in die Zelle setzen
        ActiveSheet.Hyperlinks.Add XRgBezeichnung(cy, 1), Address:=file.Path
            
        'Kommentar für die Zelle festlegen
        Set cmt = XRgBezeichnung(cy, 1).AddComment
        With cmt
            .Shape.Fill.UserPicture file.Path
            .Shape.Height = 260
            .Shape.Width = 520
            .Shape.LockAspectRatio = msoFalse
        End With
        End If
       
           cy = cy + 1
        Loop
      
        Else
            MsgBox "Die Datei: " & file.Name & " kann nicht zugeordnet werden. Auf Korrekten Dateiname prüfen!", vbCritical Or vbOKOnly, "/ Problem"
        End If
        
  
    Next
    
Application.ScreenUpdating = True

End Sub