Excel Macro to read cell values of all Excel files in a folder

ReadDataFromFiles.vbs

Option Explicit

' Excel Macro to read cell values of all Excel files in a folder
' (c) ellab.org 2015
' http://ellab.org
' @angusdev
'
' |--------------------------------------------------------------|
' | File Name | File Path | Success? | 'Sheet1'!A1 | 'Sheet2'!B4 |
' |--------------------------------------------------------------|
' | b1.xls    | c:\...... | TRUE     | Bob         | 12-Jan-2015 |
' |--------------------------------------------------------------|
' | b2.xlsx   | c:\...... | TRUE     | Lucy        | 13-Jan-2015 |
' |--------------------------------------------------------------|
' | yyy.xlsx  | c:\...... | TRUE     |             |             |
' |--------------------------------------------------------------|
' | xxx.xls   | c:\...... | FALSE    |             |             |
' |--------------------------------------------------------------|
Public Sub ReadDataFromFiles()
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim fileDialogResult As Integer
    Dim row As Integer

    fileDialogResult = Application.FileDialog(msoFileDialogFolderPicker).Show
    If fileDialogResult <> 0 Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFolder = objFSO.GetFolder(Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1))
    
        Application.ScreenUpdating = False
        row = 2
        For Each objFile In objFolder.Files
            If ActiveWorkbook.FullName <> objFile.Name And _
                (EndsWith(objFile.Name, ".xls") Or EndsWith(objFile.Name, ".xlsx")) Then
                ThisWorkbook.ActiveSheet.Cells(row, 1) = objFile.Name
                ThisWorkbook.ActiveSheet.Cells(row, 2) = objFile.Path
                ThisWorkbook.ActiveSheet.Cells(row, 3) = ReadDataFromClosedWorkbook(objFile.Path, row, 4)
                row = row + 1
            End If
        Next objFile
    End If

    Application.ScreenUpdating = True
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
End Sub

Private Function EndsWith(str As String, ending As String) As Boolean
     Dim endingLen As Integer
     endingLen = Len(ending)
     EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function

Private Function GetValueByFullRange(ByRef wb As Workbook, fullRangeName As String)
    Dim sheetName As String
    Dim rangeName As String
    Dim splitted() As String
    
    splitted = Split(fullRangeName, "!")
    
    On Error Resume Next
    GetValueByFullRange = wb.Worksheets(Replace(splitted(0), "'", "")).Range(splitted(1)).Value
    On Error GoTo 0
End Function

Private Function ReadDataFromClosedWorkbook(filePath As String, row As Integer, col As Integer)
    Dim wb As Workbook
    
    On Error GoTo errorHandler
    Set wb = Workbooks.Open(filePath, True, True)
    On Error GoTo 0
    
    While col < 100
        If ThisWorkbook.ActiveSheet.Cells(1, col).Text <> "" Then
            ThisWorkbook.ActiveSheet.Cells(row, col).Value = GetValueByFullRange(wb, ThisWorkbook.ActiveSheet.Cells(1, col).Text)
            col = col + 1
        Else
            col = 32767
        End If
    Wend
    
    wb.Close False
    Set wb = Nothing
    
    ReadDataFromClosedWorkbook = True
    Exit Function
errorHandler:
    ReadDataFromClosedWorkbook = False
End Function