Moin!
HIer mal dein Code angepasst. Sollte eigentlich passen. Die Unterordner sollten mit ausgelsen werden un die Suche ist auf Spalte B beschränkt.

Einfach mal testen.

VG

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 UO As Object
Dim Col As New Collection
Dim UOrdner As New Collection
Set FSO = CreateObject("Scripting.Filesystemobject")
 
UOrdner.Add FSO.getfolder(InPath)

Do While UOrdner.Count > 0
    
    Set Ordner = UOrdner(1)
    UOrdner.Remove 1
    
    For Each UO In Ordner.SubFolders
        UOrdner.Add UO
    Next
    
    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.Columns("B:B")   '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
Loop
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