Как искать файлы в нескольких подпапках?

Question

С помощью нескольких предыдущих вопросов я смог написать код для поиска файлов с определенным именем в нескольких подпапках.

У меня есть папка с несколькими подпапками, и некоторые подпапки также содержат больше подпапок. Коды, которые я нашел, ищут все эти подпапки, а также подпапки. Но я хочу, чтобы мой код просматривал только подпапки, т. Е. только первый слой.

Может ли кто-нибудь помочь мне с этим?

Function Recurse(sPath As String) As String

Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim mySubSubFolder As Folder
Dim myFile As File
Dim Path As String
Dim f As Integer
Dim i As Integer
Dim j As Integer
Set myFolder = FSO.GetFolder(sPath)
Dim myComp

For Each mySubFolder In myFolder.SubFolders

    f = -1

    For Each myFile In mySubFolder.Files

        If ((InStr(myFile.Name, "Beurteilungsblatt") > 0) And (InStr(myFile.Name, ".xlsm") > 0)) Then
            Debug.Print (myFile.Name)
            f = f + 1
        End If
    Next

    Dim arr()
    ReDim arr(f)

    i = 0
        For Each myFile In mySubFolder.Files
            If ((InStr(myFile.Name, "Beurteilungsblatt") > 0) And (InStr(myFile.Name, ".xlsm") > 0)) Then
                Workbooks.Open (myFile.Path)
                Set wbok1Current = ActiveWorkbook
                arr(i) = wbok1Current.Worksheets("Beurteilungsblatt").Range("FK10")
                i = i + 1
                wbok1Current.Close
            End If
        Next

    For j = 0 To f - 1
        Dim str As String
        Dim str1 As String
        str = arr(j)
        str1 = arr(j + 1)
        myComp = StrComp(str, str1, 1)
        If (myComp = 0) Then
            GoTo Continuej
        Else
            MsgBox ("Die Beurteilungsblätter sind nicht von selben Fahrzeug!" & vbCrLf & "Please Check " & str & " and " & str1 & ".")
            GoTo NextFolder
        End If
Continuej:
    Next j

    For Each myFile In mySubFolder.Files

        If ((InStr(myFile.Name, "Beurteilungsblatt") > 0) And (InStr(myFile.Name, ".xlsm") > 0)) Then

          '  MsgBox myFile.Name & " in " & myFile.path 'Or do whatever you want with the file
          '  Exit For


                Workbooks.Open (myFile.Path)
                Set wbok1Current = ActiveWorkbook


                If (IsRangeEmpty(Range("CR10:EY10")) And wbok1Current.Worksheets("Beurteilungsblatt").Range("EZ10").Value = "0" And wbok1Current.Worksheets("Beurteilungsblatt").Range("FA10").Value = "0" And wbok1Current.Worksheets("Beurteilungsblatt").Range("FB10").Value = "0" And wbok1Current.Worksheets("Beurteilungsblatt").Range("FJ10").Value = "") Then
                    GoTo ContinueDo
                End If

                Path = wbok1Current.Path

    ' do something


ContinueDo:
                    wbok1Current.Close
                    wbokCurrent.Activate

        End If

    Next
    Recurse = Recurse(mySubFolder.Path)

    wbokCurrent.Activate
    Dim dateinam As String
    dateinam = Worksheets("Fahrzeug").Range("CC2").Value
    If dateinam = "" Then
        Exit Function
    Else
    Application.DisplayAlerts = False
'    wbokCurrent.SaveAs Filename:=ThisWorkbook.Path & "\Auswertung_" & dateinam & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    wbokCurrent.SaveCopyAs FileName:=Path & "\" & dateinam & ".xlsm" 'FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True
    End If
    Range("A13:CD53").Select                'Löschen
    Application.CutCopyMode = False         'Löschen
    Selection.ClearContents                 'Löschen
    Range("A13").Select                     'Löschen

NextFolder:

Next

Функция завершения