Guten Tag,

kann mir jemand helfen zu meinem bestehenden Programm, das Durchsuchen von Unterordnern dazu zu programmieren?

Public Sub Suche()
' öffnet Workbooks im "InPath" und sucht nach "xSearch"
' On Error GoTo err
Dim xSearch As String
xSearch = InputBox("Bitte Suchbegriff eingeben")                                         ' Suchstring anpassen
Dim InPath As String
InPath = "H:\Tests"                                                                      ' Pfad anpassen
                                                                                         ' Erweiterung weiter unten anpassen

If Right(InPath, 1) <> "\" Then InPath = InPath & "\"
If Dir(InPath, vbDirectory) = "" Then
  MsgBox "Der Ordner " & InPath & " wurde nicht gefunden.", vbCritical
  Exit Sub
End If

Dim found As Boolean, zVerz As Long
Dim WS As Worksheet
Dim WB As Workbook
Dim VWS As Worksheet
Set VWS = ThisWorkbook.Worksheets("Verzeichnis")                                         ' Verzeichnis mit gefundenen Aufragsnummern
Dim f As Range, firstAddress As String
Dim FSO As Object, Element As Object, Datei As Variant, Ordner As Variant
Dim Col As New Collection
Set FSO = CreateObject("Scripting.Filesystemobject")

Set Ordner = FSO.getfolder(InPath)

For Each Datei In Ordner.Files
    Select Case LCase(FSO.GetExtensionName(Datei))
        Case "xls", "xlsx", "xlsm"                                                       ' Erweiterung anpassen
            If Left(Datei.Name, 1) <> "~" Then Col.Add Datei
    End Select
Next Datei

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual                                            ' automatische Berechnung ausschalten
Application.EnableEvents = False                                                         ' Events ausschalten
Application.DisplayAlerts = False                                                        ' Excel-Dialog-Fenster ausschalten



zVerz = 2
VWS.Columns("A").ClearContents
found = False
For Each Element In Col
    If Element.Name <> ThisWorkbook.Name Then
        Set WB = Workbooks.Open(Filename:=Element, ReadOnly:=True)
        For Each WS In WB.Worksheets
            With WS.UsedRange
            Set f = .Find(xSearch, LookIn:=xlValues)
                If Not f Is Nothing Then
                    firstAddress = f.Address
                    Do
                        VWS.Cells(zVerz, 1).Value = " '" & xSearch & "' Datei: " _
                            & Chr(13) & Element & "     'Blatt: " & WS.Name & "      'Zelle: " & f.Address(0, 0)
                        zVerz = zVerz + 1
'                        MsgBox "'" & xSearch & "' zuerst gefunden in " _
'                            & Chr(13) & Element & "'" & WS.Name & "'!" & f.Address(0, 0)
'                        WS.Range(f.Address(0, 0)).Select
'                        found = True
'                        Exit For
                        Set f = .FindNext(f)
                    Loop While Not f Is Nothing And f.Address <> firstAddress
                End If
            End With
            If found = True Then Exit For
        Next WS
        If found = False Then Workbooks(Element.Name).Close savechanges:=False
    End If
    If found = True Then Exit For
Next Element
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Set FSO = Nothing
Exit Sub

err:
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Error: " & vbCrLf & "Fehlernummer: " & err.Number & _
            vbCrLf & "Fehlerbeschreibung: " & err.Description, vbOKOnly + vbCritical, "error"
Set FSO = Nothing

End Sub

Gruß Lars