Loop each folder and subfolder to get values Any tips or improvement to speed my code? I'm looping each file in the specify folder and subfolders. I will open each file and get the values I need and copy it to my activesheet. It is taking quit some time, any tips to help?

FolderName = InputBox("Enter path", "Get File")

Dim fso, oFolder, oSubfolder, oFile, queue As Collection

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder(FolderName)

Do While queue.Count &gt; 0
    Set oFolder = queue(1)
    queue.Remove 1 'dequeue
    For Each oSubfolder In oFolder.SubFolders
        If UCase(oSubfolder.Name) &lt;&gt; "DO NOT USE" Then
            queue.Add oSubfolder 'enqueue
        Else
        End If
    Next oSubfolder
    Dim lastUsedRow As Long
    lastUsedRow = ActiveSheet.Range("A" &amp; ActiveSheet.Rows.Count).End(xlUp).Row + 1
    For Each oFile In oFolder.Files
        'Process each file but exclude files such as "~xxxxxx" or thumbs.db or xxxx.tmp files
        If oFile.Type = "Microsoft Excel Worksheet" Then
            If Not oFile.Name Like "*~*" Then                    
                Dim app As New Excel.Application
                Dim Filename As String
                Filename = oFile.Path
                app.Visible = False 'Visible is False by default, so this isn't necessary
                Dim book As Excel.Workbook
                Set book = app.Workbooks.Add(Filename)
                ActiveSheet.Range("A" &amp; lastUsedRow) = oFile.Name
                ActiveSheet.Range("B" &amp; lastUsedRow) = oFile.DateCreated
                ActiveSheet.Range("E" &amp; lastUsedRow) = book.Sheets("mySheet").Range("D3").Value
                ActiveSheet.Range("F" &amp; lastUsedRow) = book.Sheets("mySheet").Range("G12").Value
                ActiveSheet.Range("G" &amp; lastUsedRow) = book.Sheets("mySheet").Range("C9").Value
                ActiveSheet.Range("H" &amp; lastUsedRow) = book.Sheets("mySheet").Range("C13").Value
                book.Close SaveChanges:=False
                app.Quit
                Set app = Nothing
                lastUsedRow = ActiveSheet.Range("A" &amp; ActiveSheet.Rows.Count).End(xlUp).Row + 1
            End If
        End If
    Next oFile
Loop
As Mathieu Guindon mentioned in the comments, the main slow down is that you are creating a new Excel.Application for each file.   I would personally just use the current Application and turn off Application.ScreenUpdating.

Using an InputBox to prompt an user to enter a folder path is very prone to error. You should test if the folder exists.


FolderName = InputBox("Enter path", "Get File")
Do While Len(Dir(FolderName, vbDirectory)) = 0
    If Len(Dir(FolderName, vbDirectory)) = 0 Then
        If MsgBox("Do you wish to continue?", vbYesNo, "Invalid Folder") &lt;&gt; vbYes Then
            Exit Sub
        Else
            FolderName = InputBox("Enter path", "Get File")
        End If
    End If
Loop



Or better yet just use Application.FileDialog(msoFileDialogFolderPicker) to pick the folder.  It's the right tool for the job.

Using an Array to collect the data and writing it to a range of cells in one operation is much faster the writing each piece of data to an individual cell.

Refactored Code

Here is how I would write the code.  Notice that I created a subroutine to collect the files and another to get the Folder Path.  This allows me to debug each part of the code separately.  

Sub LoopFoldersAndXLFiles()
    Dim t As Double: t = Timer
    Const SheetName As Variant = 1
    Dim FileList As Collection
    addExcelFileList FileList
    If FileList.Count = 0 Then Exit Sub

    Dim oFile As Object, xlApp As New Excel.Application
    Dim r As Long
    Dim results() As Variant
    ReDim results(1 To FileList.Count, 1 To 8)
    For r = 1 To FileList.Count
        Set oFile = FileList(r)
        With xlApp.Workbooks.Add(oFile.Path)
            results(r, 1) = oFile.Name
            results(r, 2) = oFile.DateCreated
            results(r, 5) = .Sheets(SheetName).Range("D3").Value
            results(r, 6) = .Sheets(SheetName).Range("G12").Value
            results(r, 7) = .Sheets(SheetName).Range("C9").Value
            results(r, 8) = .Sheets(SheetName).Range("C13").Value
            .Close SaveChanges:=False
        End With
    Next

    xlApp.Quit

    With ActiveSheet
        With .Range("A" &amp; .Rows.Count).End(xlUp).Offset(1)
            .Resize(UBound(results), UBound(results, 2)).Value = results
        End With
    End With
    Debug.Print Round(Timer - t, 2)
End Sub

Sub addExcelFileList(ByRef FileList As Collection, Optional FolderName As String, Optional fso As Object)
    If Len(FolderName) = 0 Then
        FolderName = getFolderPath
        If Len(FolderName) = 0 Then Exit Sub
    End If
    If FileList Is Nothing Then Set FileList = New Collection
    If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject")

    Dim oFolder As Object, oSubfolder As Object

    Set oFolder = fso.GetFolder(FolderName)

    For Each oSubfolder In oFolder.SubFolders
        If UCase(oSubfolder.Name) &lt;&gt; "DO NOT USE" Then addExcelFileList FileList, oSubfolder.Path, fso
    Next

    Dim oFile As Object
    For Each oFile In oFolder.Files
        If oFile.Type = "Microsoft Excel Worksheet" And Not oFile.Name Like "*~*" Then FileList.Add oFile
    Next
End Sub

Function getFolderPath() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show &lt;&gt; -1 Then Exit Function
        getFolderPath = .SelectedItems(1)
    End With
End Function