List folders in directory, if any sub-folder contains string

[Formula11]

With this macro, sub-folders are listed for first and second levels (based on selected folder). The output is divided into separate columns in this example.
I now want it to list folders only if any of the sub-folders contain the string "OK". The sub-folder with this string can be at any level.


EXAMPLE:

Selected folder
..... Subfolder 1-A
.......... Subfolder 2-A
.................... Subfolder 3-A OK
......................... Subfolder 4-A
......................... Subfolder 4-B
.................... Subfolder 3-B
......................... Subfolder 4-C
.......... Subfolder 2-B
.................... Subfolder 3-C
..... Subfolder 1-B
.......... Subfolder 2-C
.................... Subfolder 3-D
......................... Subfolder 4-D
......................... Subfolder 4-E
.................... Subfolder 3-E
.......... Subfolder 2-D
.......... Subfolder 2-E
.................... Subfolder 3-F
......................... Subfolder 4-F
.................... Subfolder 3-G
......................... Subfolder 4-G
......................... Subfolder 4-H
.................... Subfolder 3-H
.................... Subfolder 3-I
......................... Subfolder 4-I
..... Subfolder 1-C
.......... Subfolder 2-F
.......... Subfolder 2-G
.......... Subfolder 2-H
.................... Subfolder 3-J
......................... Subfolder 4-J OK

CURRENT OUTPUT
--------------
Subfolder 1-A      Subfolder 1-B      Subfolder 1-C 
Subfolder 2-A      Subfolder 2-C      Subfolder 2-F
Subfolder 2-B      Subfolder 2-D      Subfolder 2-G
                   Subfolder 2-E      Subfolder 2-H

DESIRED OUTPUT
--------------
Subfolder 1-A      Subfolder 1-C 
Subfolder 2-A      Subfolder 2-H

Sub getfolders()
Dim fs, f, fc, fcsub
Dim n As String
Dim r As Integer, c As Integer
    ' Open the Browse Folder dialog
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
            .InitialFileName = "C:\"
            If .Show = 0 Then   'User pressed Cancel
            Exit Sub
            End If
            folderspec = .SelectedItems(1)
        End With
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.subfolders
    n = f.Name
    r = 1
    c = 1
    For Each f1 In fc
        Sheets(1).Cells(r, c) = f1.Name
        Set fcsub = f1.subfolders
        r = r + 1
            For Each f2 In fcsub
                Sheets(1).Cells(r, c) = f2.Name
                r = r + 1
            Next
        c = c + 1
        r = 1
    Next
End Sub

 

[Formula11]

I managed to get to this point. It seems to work but has the following inconsistency:
- It only lists the subfolder if it is the first one in the set. So for the subfolder set {Subfolder 3-A OK, Subfolder 3-B}, it will work, but if I have {ASubfolder, Subfolder 3-A OK, Subfolder 3-B}, it will not work.
I can't figure out why this occurs.

Notes on code:
- Microsoft Scripting Runtime required as reference (Tools/References)
- Specify directory in variable folderspec
- Specify word/string in Function (in this case "OK")
- Output starts at cell J1

'References: Microsoft Scripting Runtime

Dim Exists As Boolean

Sub Regather()
    Dim fs, fc, fcsub
    Dim f As Scripting.Folder, f1 As Scripting.Folder
    Dim n As String
    Dim r As Integer, C As Integer
    Dim folderspec As String
    Dim OriginalLocation As Range
    Application.ScreenUpdating = False
    Set OriginalLocation = Selection
    Range(Range("J1"), Cells(Rows.Count, Columns.Count)).ClearContents
    folderspec = "C:\" '********** Directory
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.subfolders
    n = f.Name
    r = 1
    C = 1
    ' Loop through folders
    For Each f1 In fc
        Exists = False
        Call LookForFolder(f1, True)
        If Exists = True Then
            Cells(r + 1, C + 9) = f1.Name
            Set fcsub = f1.subfolders
            r = r + 1
                For Each f2 In fcsub
                    Cells(r + 2, C + 9) = f2.Name
                    r = r + 1
                Next
            C = C + 1
            r = 1
         End If
    Next
End Sub

Function LookForFolder(objFolder As Scripting.Folder, IncludeSubfolders As Boolean)
    Dim objSubFolder As Scripting.Folder
    If InStr(objFolder.Path, "OK") <> 0 Then '********** Word looking for
        Exists = True
    End If
    If IncludeSubfolders Then
        For Each objSubFolder In objFolder.subfolders
            Call LookForFolder(objSubFolder, True)
            Exit Function
        Next objSubFolder
    End If
End Function