Warehouse Data From Collection of Excel Files in Different Folders (VBA)

This could take a LONG time depending on how many files your talking about.

The code consists of three sections. One Sub and two Functions.

Copy to Module code page.

Sub ImportNonBold()
Dim WS As Worksheet
Dim WBSrc As Workbook
Dim WSSrc As Worksheet
Dim Temp As Variant
Dim A As Long
Dim LastRow As Long
Dim LRSrc As Long
Dim FN As Variant
Dim AllFiles As New Collection

Application.ScreenUpdating = False

'Creates a collection of all the path/filenames
RecursiveDir AllFiles, "G:\Data\Notes\", "*.xls?", True

'Define current sheet
Set WS = ActiveSheet

With WS
    'Determine lastrow of WS
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With

'Loop through all collection of filenames
For Each FN In AllFiles
    'Open source workbook
    Set WBSrc = Workbooks.Open(FN, , True)
    'Loop through all worksheets.
    For Each WSSrc In WBSrc.Worksheets
        'Looking for match.
        If WSSrc.Name = "Data Values" Then
            With WSSrc
                'Determine lastrow of source worksheet
                LRSrc = .Cells(.Rows.Count, "B").End(xlUp).Row
                'Loop through all the rows of data
                For A = 2 To LRSrc
                    'If cell is NOT bold.
                    If Not .Range("B" & A).Font.Bold Then
                        'If cell is not empty.
                        If .Range("B" & A) <> "" Then
                            'Copy Col B&C
                            .Range("B" & A & ":C" & A).Copy
                            WS.Range("A" & LastRow).PasteSpecial xlPasteAll
                            'File where data was extracted.
                            WS.Range("C" & LastRow) = FN
                            'Increment lastrow of WS.
                            LastRow = LastRow + 1
                        End If
                    End If
                Next
            End With
        End If
    Next
    'Close source workbook and do not save changes.
    WBSrc.Close False
Next

'Bring cursor to top of worksheet.
WS.Range("A1").Select
Application.ScreenUpdating = True
End Sub
Public Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
    strTemp = Dir(strFolder & strFileSpec)
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
        strTemp = Dir(strFolder, vbDirectory)
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function


Public Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function