Hi,

Bedingungen anpassen/ändern/entfernen und von diesem rekursivem Gebilde ableiten:

Option Explicit
 
Private fso as Object
CONST s_TEILBEZEICHNUNG as String = "*aktuell*"
CONST s_LEFT_2_ORDNERNAME As String = "A-"
 
Sub main()
    Set fso = CreateObject("Scripting.FileSystemObject")
    DurchsucheOrdner "T:\Technische Dokumentation"   
End Sub
 
Sub DurchsucheOrdner(ByVal sPfad As String)
 
    Dim fil                                     As Object
    Dim subFldrKunde                            As Object
    Dim subFldrArtikel                          As Object
    Dim subFldrDokumente                        As Object
    Dim vDokumentenOrdner                       As Variant
     
    '*** zu findende Dokumentation
    vDokumentenOrdner = Array("Arbeitsanweisungen", "Maschineneinstellplan", "Verpackungsvorschriften")
     
     
    For Each subFldrKunde In fso.GetFolder(sPfad).SubFolders                                                            '*** Technische Dokumentation
             
        If (Len(subFldrKunde.ShortName) = 3) Or (Left(UCase(subFldrKunde.ShortName), 2) = s_LEFT_2_ORDNERNAME) Then     '*** Technische Dokumentation02
             
            For Each subFldrArtikel In fso.GetFolder(subFldrKunde).SubFolders                                           '*** Technische Dokumentation02A-002001
                If (Left(UCase(subFldrArtikel.ShortName), 2) = s_LEFT_2_ORDNERNAME) Then
                     
                    For Each subFldrDokumente In fso.GetFolder(subFldrArtikel).SubFolders                               '*** Technische Dokumentation02A-002001Arbeitsanweisung, Maschineneinstellplan, Verpackungsvorschrift
                        If UBound(Filter(vDokumentenOrdner, subFldrDokumente.Name)) >= 0 Then
                             
                            For Each fil In fso.GetFolder(subFldrDokumente).Files                                       '*** Dokumente; wenn im Namen "*aktuell*" auftaucht
                                If fil.Name Like s_TEILBEZEICHNUNG Then
                                 
                                    With ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp)
                                        .Offset(1, 0).Value = subFldrKunde.ShortName
                                        .Offset(1, 1).Value = subFldrArtikel.Name
                                        .Offset(1, 2).Value = subFldrDokumente.Name
                                        .Offset(1, 3).Value = fil.Name
                                        '*** Hyperlink.Add
                                        .Parent.Hyperlinks.Add Anchor:=.Offset(1, 3), Address:=subFldrDokumente.Path & "" & fil.Name
                                    End With
                                     
                                End If
                            Next
                        End If
                    Next
                End If
            Next
             
        End If
    Next
End Sub