Рекурсивный поиск

Private Sub CommandButton1_Click()
        curr_dir$ = Module1.SelDir(0)
        If curr_dir$ <> "" Then
           Me.Label2 = curr_dir$
           Me.ListBox1.Clear
           cF$ = Dir$(curr_dir$ + "\*.doc")
           Do
              If cF$ = "" Then Exit Do
              Me.ListBox1.AddItem cF$
              cF$ = Dir$()
           Loop
        End If
TPath = curr_dir
End Sub

Option Explicit
Option Base 1
 
    
 
Public TPath As String
 
Const BIF_RETURNONLYFSDIRS = 1
Const BIF_DONTGOBELOWDOMAIN = 2
Const MAX_PATH = 260
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
 
                                        
Private Type BrowseInfo
    hWndOwner      As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type
 
 
Function SelDir(hwnd As Long) As String
  
  Dim lpIDList    As Long
  Dim sBuffer     As String
  Dim szTitle     As String
  Dim tBrowseInfo As BrowseInfo
    
  szTitle = "Выбор папки :"
  
  With tBrowseInfo
    .hWndOwner = hwnd
    .lpszTitle = lstrcat(szTitle, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
  End With
  
 
  lpIDList = SHBrowseForFolder(tBrowseInfo)
 
 
  If (lpIDList) Then
     sBuffer = Space(MAX_PATH)
     SHGetPathFromIDList lpIDList, sBuffer
     sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
     SelDir = sBuffer
  Else
     SelDir = ""
  End If
  
End Function

Option Explicit
 
Sub GetData()
 
    Dim fso As New FileSystemObject
    Dim aFile As File, aFolder As Folder
    Dim wkb As Workbook, wks As Worksheet
    Dim arr(1 To 4) As Variant
    Dim iRow As Integer
    
    iRow = 2
    
    For Each aFolder In fso.GetFolder(ThisWorkbook.Path).SubFolders
    
        For Each aFile In aFolder.Files
            If fso.GetExtensionName(aFile.Name) Like "xls*" Then
            
                Set wkb = Workbooks.Open(aFile.Path)
                Set wks = wkb.Worksheets(1)
                With wks
                    arr(1) = .Range("B9").MergeArea.Cells(1, 1)
                    arr(2) = .Range("A12").MergeArea.Cells(1, 1)
                    arr(3) = .Range("I10").MergeArea.Cells(1, 1)
                    arr(4) = .Range("L10").MergeArea.Cells(1, 1)
                End With
                
                Sheet1.Cells(iRow, 1).Resize(1, 4) = arr
                iRow = iRow + 1
                
                wkb.Close SaveChanges:=False
                Set wks = Nothing
                Set wkb = Nothing
 
            End If
        Next
    
    Next
 
End Sub

    .WriteText CreateObject("wscript.shell").Exec("cmd /c dir /s/b/o:d """ & fldr & "*.doc""").StdOut.ReadAll