Loop each folder and subfolder to get values
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