Search in 2 specified directories and all subfolders for speciphic files

[thebute]

Hi All,

Recently I recived help on putting together the following macro. The macro searches in 2specified directories for workbooks with names 'worksheet'.
It works well as long as the workbooks are all pasted in the specified directories but in reality all workbooks are found in client folders that are all in the 2 specified directories.

can someone please complete the macro for me so that is not only searches directly in the 2 specified directories but also in all subfolders.

Should the macro not find any worksheet in one of the 2 specified directories and their subfolders then it should proceed to the next, instead of exiting on the first empty folder.

I uploaded the file to my GoogleDrive: (pls see module 'MasterFile')
https://drive.google.com/file/d/0B06UUoORgT0VZ2NvQmRFTDJ5aXM/edit?usp=sharing

Dim vFiles As Variant


Sub DossierNummer()
  Dim RimorMacro As String
  Dim mysht As String

  Application.ScreenUpdating = False

  RimorMacro = ActiveWorkbook.Name
  Sheets("OverzichtInhoud").Select
  Range("A2:Q2" & ActiveSheet.UsedRange.Rows.Count).ClearContents
  Range("A2").Select


  Sheets("StartPunt").Select


  get_filename
  Sheets("StartPunt").Select
  lrow = Range("E1", Selection.End(xlDown)).Count
 
  For i = 2 To lrow
    If Range("E" & i).Value = "" Then
      MsgBox "Gegevens staan nu klaar in de OverzichtInhoud!", vbInformation, "Status Kopiëren"
      Exit Sub
    Else
      Workbooks.Open Filename:=vFiles(1, i) & vFiles(2, i)
  
      mysht = ActiveWorkbook.Name
        Application.StatusBar = "Rimor RapportageTool is bezig met het verwerken van: " & mysht
            
            Sheets("Worksheet").Select
                Range("B4:B10,B29,B20,B24,B30,B31,B32,B33,B34,B35,B36").Select
                    Selection.Copy
                
      Workbooks(RimorMacro).Activate
      Sheets("OverzichtInhoud").Select
      Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True
  
      ActiveCell.Offset(0, 0).Select
        Workbooks("" & mysht & "").Activate
            Range("B24").Select
 
ActiveCell.Offset(0, 0).Select
    Workbooks("" & mysht & "").Activate
        Range("B24").Select
 
Selection.End(xlDown).Select
Selection.Copy
Workbooks("" & RimorMacro & "").Activate
Selection.PasteSpecial Paste:=xlPasteValues
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Sheets("StartPunt").Select
      
      Workbooks(mysht).Close SaveChanges:=False
      Workbooks(RimorMacro).Activate
    End If
  Next i
  Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub






Sub get_filename()
  Const sPathRange As String = "C3,C7"
  Const iIncr As Long = 50

  Dim fdr As String
  
  ' this range will store your paths
  Dim rngPathList As Excel.Range
  Dim rng As Excel.Range
  
  Dim iSize As Long

  iSize = iIncr
  
  mrow = 2
  
  ReDim vFiles(1 To 2, 2 To iSize)
  
  Set rngPathList = Range(sPathRange)
  
  Range(Range("E2"), Range("E2").End(xlDown)).ClearContents
  Range("E2").Select
  
  For Each rng In rngPathList
    spath = rng.Value
    fdr = Dir(spath & "\*Worksheet*.xlsm")
    
    Do While fdr <> ""
      If mrow > iSize Then
        iSize = iSize + iIncr
        ReDim Preserve vFiles(1 To 2, 2 To iSize)
      End If

      vFiles(1, mrow) = spath & Application.PathSeparator
      vFiles(2, mrow) = fdr
      
      Cells(mrow, 5).Value = fdr
      
      fdr = Dir
      mrow = mrow + 1
    Loop
    
    If iSize >= mrow Then
      iSize = mrow - 1
      ReDim Preserve vFiles(1 To 2, 2 To iSize)
    End If
  Next rng
End Sub

thanks you all in advance
thebute