How to loop through all SubFolders and get contents of Row 1 of each Excel file?

Question

I am trying to figure out a way to open all Excel files in all SubFolders, and get the all values from all cells in Row 1 and all formats for all these cells. I think my code b

Answer 1

I think it's easier to manage the process if you get all of the matching files first, and then loop through them.

Lightly tested:

Sub GetFolder_Data_Collection()

    Dim colFiles As Collection, c As Range
    Dim strPath As String, f, sht As Worksheet
    Dim wbSrc As Workbook, wsSrc As Worksheet
    Dim rw As Range

    Set sht = ActiveSheet

    strPath = GetFolder

    Set colFiles = GetFileMatches(strPath, "*.xls*", True)

    With sht
        .Range("A:L").ClearContents
        .Range("A1").Resize(1, 5).Value = Array("Name", "Path", "Cell", "Value", "Numberformat")
        Set rw = .Rows(2)
    End With

    For Each f In colFiles
        Set wbSrc = Workbooks.Open(f)
        Set wsSrc = wbSrc.Sheets(1)
        For Each c In wsSrc.Range(wsSrc.Range("a1"), _
                                  wsSrc.Cells(1, Columns.Count).End(xlToLeft)).Cells

            sht.Hyperlinks.Add Anchor:=rw.Cells(1), Address:=wbSrc.Path, TextToDisplay:=wbSrc.Name
            rw.Cells(2).Value = wbSrc.Path
            rw.Cells(3).Value = c.Address(False, False)
            rw.Cells(4).Value = c.Value
            rw.Cells(5).Value = c.NumberFormat
            Set rw = rw.Offset(1, 0)
        Next c
        wbSrc.Close False
    Next f
End Sub


'Return a collection of file objects given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetFileMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr
    Dim colFiles As New Collection
    Dim colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder

    Do While colSub.Count > 0
        Set fldr = fso.GetFolder(colSub(1))
        colSub.Remove 1

        For Each f In fldr.Files
            If UCase(f.Name) Like UCase(filePattern) Then colFiles.Add f
        Next f
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set GetFileMatches = colFiles
End Function

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function

Answer 2

It can do like this also.

Sub GetFileFromFolder()
    Dim n           As Long
    Dim fd As FileDialog
    Dim strFolder As String
    Dim colResult As Collection
    Dim i As Long, k As Long
    Dim vSplit
    Dim strFn As String
    Dim vR() As String
    Dim p As String
    Dim Wb As Workbook
    Dim sht As Worksheet, Ws As Worksheet
    Dim rng As Range, rngDB As Range


    Set sht = ThisWorkbook.Worksheets("Sheet1")

        p = Application.PathSeparator
        Set fd = Application.FileDialog(msoFileDialogFolderPicker)
        With fd
            .Show
            .InitialView = msoFileDialogViewList
            .Title = "Select Folder"
            .AllowMultiSelect = False
            If .SelectedItems.Count = 0 Then
            Else
                strFolder = .SelectedItems(1)
                Set colResult = SearchFolder(strFolder)

                i = colResult.Count
                For k = 1 To i
                    If colResult(k) Like "*.xls*" Then
                        n = n + 1
                        ReDim Preserve vR(1 To 5, 1 To n)
                        Set Wb = Workbooks.Open(colResult(k))
                        Set Ws = Wb.Worksheets(1)

                        lngColCount = Ws.UsedRange.Columns.Count

                        vSplit = Split(colResult(k), p)
                        strFn = vSplit(UBound(vSplit))
                        vR(1, n) = strFn
                        vR(2, n) = Left(colResult(k), Len(colResult(k)) - Len(strFn))
                        vR(3, n) = colResult(k)
                        vR(4, n) = Ws.Cells(1, lngColCount).Value
                        vR(5, n) = Ws.Cells(1, lngColCount).NumberFormat
                        Wb.Close (0)
                    End If
                Next k
                With sht
                    .UsedRange.Clear
                    .Range("A1").Value = "Name"
                    .Range("B1").Value = "Path"
                    .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
                    Set rngDB = .Range("c2").Resize(n)
                    For Each rng In rngDB
                        .Hyperlinks.Add Anchor:=rng, Address:=rng.Value
                    Next rng
                    .Columns.AutoFit
                End With
            End If
        End With
End Sub
Function SearchFolder(strRoot As String)
    Dim FS As Object
    Dim fsFD As Object
    Dim f As Object

    Dim colFile As Collection
    Dim p As String

    On Error Resume Next
    p = Application.PathSeparator
    If Right(strRoot, 1) = p Then
    Else
        strRoot = strRoot & p
    End If

    Set FS = CreateObject("Scripting.FileSystemObject")
    Set fsFD = FS.GetFolder(strRoot)
    Set colFile = New Collection
    For Each f In fsFD.Files
        colFile.Add f.Path
    Next f

    SearchSubfolder colFile, fsFD

    Set SearchFolder = colFile
    Set fsFD = Nothing
    Set FS = Nothing
    Set colFile = Nothing

End Function
Sub SearchSubfolder(colFile As Collection, objFolder As Object)
    Dim sbFolder As Object
    Dim f As Object
    For Each sbFolder In objFolder.subfolders
        SearchSubfolder colFile, sbFolder
        For Each f In sbFolder.Files
            colFile.Add f.Path
        Next f
    Next sbFolder

End Sub