Ceate a root directory to select multiple files at once.

Hi,

The attached zip file contains files:
a. ExcelForumProcessFilesInSubFolders2.xls - Updated copy of the previous file that actually processes files and puts results in a destination file.
b. ExcelForumDestinationFile.xlsx - Simulated destination file.
c. ExcelForumSourceFile1.xlsx - Simulated source file
d. ExcelForumSourceFile2.xlsx - Simulated source file with different data

The following contains code excerpts to demonstrate how the source and destination files are processed:

Option Explicit

Private Const sControlSheetNAME = "Sheet1"
Private Const sDestinationSheetNAME = "Sheet1"
Private Const sBaseFolderNameCELL = "C5"
Private Const sFolderSearchStringCELL = "C7"
Private Const sDestinationFolderandFileNameCELL = "C9"
Private Const nDoubleLineROW = 25

Sub ProcessOneSourceFile(sPathAndMatchingFileName As String, wsDestination As Worksheet)
  'Your file processing code goes in this routine
  
  Dim wbSource As Workbook
  Dim wsDeckblatt As Worksheet
  Dim wsCoverSheet As Worksheet  'Just in Case there is an English and Non-English Version
  
  Dim iDestinationSheetLastRowUsed As Long
  Dim iDestinationRow As Long
  
  Dim sSourceFileName As String
  Dim sSourceFolderName As String

  'Get the Source Folder and File Names
  sSourceFolderName = LjmExtractPath(sPathAndMatchingFileName)
  sSourceFileName = LjmExtractFullFileName(sPathAndMatchingFileName)

  'Open  the SourceFile
  Set wbSource = Workbooks.Open(FileName:=sPathAndMatchingFileName, ReadOnly:=True)
  
  'Create the Worksheet Objects
  Set wsDeckblatt = wbSource.Sheets("Deckblatt")
  Set wsCoverSheet = wbSource.Sheets("Cover Sheet")
  
  'Find the Last Row Used on the Destination Sheet (A runtime error will occur if the Sheet is Empty)
  On Error Resume Next
  iDestinationSheetLastRowUsed = wsDestination.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  If Err.Number <> 0 Then
    Err.Clear
    iDestinationSheetLastRowUsed = 1
  End If
  On Error GoTo 0
  
  'Set the Destination Row to the Last Row after the Last Row Used on the Destination Sheet
  iDestinationRow = iDestinationSheetLastRowUsed + 1
  
  
  'Copy Administrative Data to the 'Destination' Sheet
  wsDestination.Cells(iDestinationRow, "A").Value = sSourceFileName
  wsDestination.Cells(iDestinationRow, "B").Value = sSourceFolderName
  
  
  'Copy Data from Sheet 'Cover Sheet' to the 'Destination' Sheet
  wsDestination.Cells(iDestinationRow, "C").Value = wsCoverSheet.Range("F3").Value
  wsDestination.Cells(iDestinationRow, "D").Value = wsCoverSheet.Range("D14").Value
  
  
  'Copy Data from Sheet 'Deckblatt' to the 'Destination' Sheet
  wsDestination.Cells(iDestinationRow, "E").Value = wsDeckblatt.Range("D3").Value
  wsDestination.Cells(iDestinationRow, "F").Value = wsDeckblatt.Range("D7").Value
  wsDestination.Cells(iDestinationRow, "G").Value = wsDeckblatt.Range("D11").Value
  
  
  'Close Source File
  wbSource.Close SaveChanges:=False

  'Clear  Object pointers
  Set wbSource = Nothing
  Set wsDeckblatt = Nothing
  Set wsCoverSheet = Nothing
  
End Sub

Sub ProcessMatchingFilesInAllSubFolders()
  'This will process all Matching Files in all SubFolders

  Dim wbDestination As Workbook
  Dim wsControl As Worksheet
  Dim wsDestination As Worksheet
  Dim fso As Object
  Dim objFolder As Object

  Dim iLevel As Long
  Dim iMatchCount As Long
  Dim iOutputRow As Long
  Dim sBaseFolder As String
  Dim sBaseFolderAndFileMaskCombination As String
  Dim sDestinationFileName As String
  Dim sDestinationPath As String
  Dim sDestinationPathAndFileName As String
  Dim sFileMask As String
  Dim sMatchingFileName As String
  Dim sPathAndMatchingFileName As String
  Dim sPathAndMatchingFolderName As String
  Dim sSearchSpec As String
  
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Initialization
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Code deleted
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Get the Input values and display their values
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Code deleted - comments left behind

  'Get the Base Folder Name (without leading/trailing spaces)
  
  'Get the File Mask (without leading/trailing spaces)
  'Add a '*' (find all matches) to the end of the Search Spec if there is no '*' in the 'Partial Folder Name'
  
  'Get the Destination Path and File Name
  

  'Build the complete 'Search Specification'
  sBaseFolderAndFileMaskCombination = sBaseFolder & sFileMask
  
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Search Preliminaries
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'Create the File System Object
  'Create the Folder Object
  'Exit if the 'Base Folder' does not exist.
  Set fso = CreateObject("Scripting.FileSystemObject")
  On Error Resume Next
  Set objFolder = fso.GetFolder(sBaseFolder)
  If Err.Number <> 0 Then
    MsgBox "NOTHING DONE.  The 'Base Folder' does NOT exist." & vbCrLf & _
           "Base Folder Name: '" & sBaseFolder & "'"
    GoTo MYEXIT
  End If
  On Error GoTo 0
  
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Open the Destination File
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  sDestinationPath = LjmExtractPath(sDestinationPathAndFileName)
  sDestinationFileName = LjmExtractFullFileName(sDestinationPathAndFileName)
  
  If LJMFileExists(sDestinationPathAndFileName) = False Then
    MsgBox "NOTHING DONE.  The 'Destination Folder and/or File' does NOT exist." & vbCrLf & _
           "Folder: '" & sDestinationPath & "'" & vbCrLf & _
           "File: '" & sDestinationFileName & "'"
    GoTo MYEXIT
  End If
  
  If LjmIsWorkbookOpen(sDestinationFileName) = True Then
    MsgBox "NOTHING DONE.  The 'Destination File is NOT ALLOWED to be OPEN." & vbCrLf & _
           "Try again after the Destination File is CLOSED." & vbCrLf & _
           "Name: '" & sDestinationFileName & "'"
    GoTo MYEXIT
  End If
  
  'Create the Destination Objects
  Set wbDestination = Workbooks.Open(sDestinationPathAndFileName)
  
  If LjmWorkbookAndSheetExists(sDestinationFileName, sDestinationSheetNAME) = False Then
    MsgBox "NOTHING DONE.  The 'Destination File MUST CONTAIN Sheet '" & sDestinationSheetNAME & "'." & vbCrLf & _
           "Folder: '" & sDestinationPath & "'" & vbCrLf & _
           "File: '" & sDestinationFileName & "'"
    GoTo MYEXIT
  End If
  
  Set wsDestination = wbDestination.Sheets(sDestinationSheetNAME)

  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Find all matches in the 'Base Folder' Only
  'Dir() is used in favor of FileSystemObject to allow wildcard search
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  sPathAndMatchingFolderName = sBaseFolder
    
  'Output a Message
  iOutputRow = iOutputRow + 1
  wsControl.Cells(iOutputRow, "A").Value = "-----  " & "Folder: " & sPathAndMatchingFolderName
    
  'Create the 'Search Specification' for Dir()
  'Get the First Matching File Name (if any)
  sSearchSpec = sPathAndMatchingFolderName & sFileMask
  sMatchingFileName = Dir(sSearchSpec)
    
  'Keep on Processing until the 'Matching File Name' is BLANK
  While Len(sMatchingFileName) > 0
    
    'Build the Complete Path and File Name
    sPathAndMatchingFileName = sPathAndMatchingFolderName & sMatchingFileName
      
    'Increment the Match Counter
    'Output a Message
    iMatchCount = iMatchCount + 1
    iOutputRow = iOutputRow + 1
    wsControl.Cells(iOutputRow, "A").Value = Format(iMatchCount, "000  ") & "Processing " & sPathAndMatchingFileName
      
    'User Specific File Processing
    Call ProcessOneSourceFile(sPathAndMatchingFileName, wsDestination)
      
    'Get the Next File Name
    sMatchingFileName = Dir()
  Wend
          
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Recursively Search SubFolders
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  iLevel = 0
  Call RecursiveFolderSearch(sBaseFolder, sFileMask, sBaseFolder, iLevel, iMatchCount, iOutputRow, wsControl, wsDestination)
    
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Output Completion Messages
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  If iMatchCount = 0 Then
    iOutputRow = iOutputRow + 1
    wsControl.Cells(iOutputRow, "A").Value = "NO matching Folders were found."
  End If
  
  'Output a completion message
  iOutputRow = iOutputRow + 1
  iOutputRow = iOutputRow + 1
  wsControl.Cells(iOutputRow, "A").Value = "Search completed on " & Format(Now(), "ddd mmmm d, yyyy  hh:mm:ss AM/PM") & "."
  
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Termination
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  'AutoFit the Destination Sheet Columns
  wsDestination.Cells.Columns.AutoFit
  
MYEXIT:
  'Restore Screen Updating
  Application.ScreenUpdating = True
  
  'Close and save the 'Destination File' if possible
  On Error Resume Next
  wbDestination.Save
  wbDestination.Close
  On Error GoTo 0

  'Clear Object Pointers
  Set fso = Nothing
  Set objFolder = Nothing
  Set wsControl = Nothing
  Set wbDestination = Nothing
  Set wsDestination = Nothing
End Sub

Sub RecursiveFolderSearch(sPath As String, _
                          sFileMask As String, _
                          sBaseFolder As String, _
                    ByRef iLevel As Long, _
                    ByRef iMatchCount As Long, _
                    ByRef iOutputRow As Long, _
                          wsControl As Worksheet, _
                          wsDestination As Worksheet)
  'This recursively searches for Folder Names
  '
  'This ignores folders in 'Level 0' (Base Folder) to allow a prior search for 'Base Folder' matches
  '
  ' 'ByRef' items are modified by this routine

  Dim fso As Object
  Dim objFolder As Object
  Dim objSubFolder As Object
  
  Dim sMatchingFileName As String
  Dim sPathAndMatchingFileName As String
  Dim sPathAndMatchingFolderName As String
  Dim sSearchSpec As String
  Dim sSubFolderName As String

  'Create the File System Object
  'Create the Folder Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objFolder = fso.GetFolder(sPath)

  'Traverse Each SubFolder
  For Each objSubFolder In objFolder.SubFolders
    
    'Get the Next SubFolder Name
    'Build the Complete Folder and SubFolder Name
    sSubFolderName = objSubFolder.Name
    sPathAndMatchingFolderName = sPath & sSubFolderName & "\"
    
      
    'Increment the Output Row
    'Create an Output Message
    iOutputRow = iOutputRow + 1
    wsControl.Cells(iOutputRow, "A").Value = "-----  " & "Folder: " & sPathAndMatchingFolderName
      
    'Create the 'Search Specification' for Dir()
    'Get the First Matching File Name (if any)
    sSearchSpec = sPathAndMatchingFolderName & sFileMask
    sMatchingFileName = Dir(sSearchSpec)
      
    'Keep on Processing until the 'Matching File Name' is BLANK
    While Len(sMatchingFileName) > 0
      
      'Build the Complete Path and File Name
      sPathAndMatchingFileName = sPathAndMatchingFolderName & sMatchingFileName
      
      'Increment the Match Counter
      'Output a Message
      iMatchCount = iMatchCount + 1
      iOutputRow = iOutputRow + 1
      wsControl.Cells(iOutputRow, "A").Value = Format(iMatchCount, "000  ") & "Processing " & sPathAndMatchingFileName
      
      'User Specific File Processing
      Call ProcessOneSourceFile(sPathAndMatchingFileName, wsDestination)
      
      'Get the Next File NAME
      sMatchingFileName = Dir()
    Wend
      
    'Drill down to the next Sub-Level
    Call RecursiveFolderSearch(sPath & objSubFolder.Name & "\", sFileMask, sBaseFolder, iLevel + 1, iMatchCount, iOutputRow, wsControl, wsDestination)
    
  Next objSubFolder
  
  
MYEXIT:

  'Clear object pointers
  Set fso = Nothing
  Set objFolder = Nothing
  
End Sub

Lewis