Extracting data from multiple excel spreadsheets

[crimzonclover]

Help!

I'm trying to create a report that pulls information about a certain folder. I found code online that basically pulls information from the folder and its subfolders (i.e.: Name, Path, Date Created, Last Modified).

It works like a dream.

What I'd like to do now is that once that code has finished, I want to search through those files and pull information from certain cells in each spreadsheet and put that information in the next columns of the corresponding row.

I've pasted the code from getting the folder information.. Please help!

' Comments: Receives user input on the folder to be analyzed
' Based on the input this proc generates a report
' of chosen file properties for a selected folder.
Sub GenerateFolderReport()
Dim FFolder As FFolderReport
Dim bContinue As Boolean
Dim sPath As String
Dim bSubFolders As Boolean
Dim vFileProps As Variant
Dim vReport As Variant
Dim wkbOutput As Workbook
Dim lSheet As Long
Dim lMaxRecord As Long
Dim lRecord As Long
Dim lField As Long

'Create a new instance of the Userform
Set FFolder = New FFolderReport

'Show the form and return its properties
With FFolder
.Show
bContinue = .OK
sPath = .Folder
bSubFolders = .SubFolders
vFileProps = .FileProperties
End With

'Remove the form as we no longer need it
Unload FFolder

'If the user clicked OK then continue
If bContinue Then
'Load the folder details report into a variant
vReport = FolderDetails(sPath, bSubFolders, vFileProps, True)

'Transpose the return array
vReport = Transpose2DArray(vReport)

Application.ScreenUpdating = False

'Create the report worbook
Set wkbOutput = Application.Workbooks.Add

With wkbOutput
'Remove all sheets except the first one from the book.
Application.DisplayAlerts = False
For lSheet = Application.SheetsInNewWorkbook To 2 Step -1
.Worksheets(lSheet).Delete
Next lSheet
Application.DisplayAlerts = True

'Trap for reports that will not fit on a worksheet
If UBound(vReport, 2) > 65536 Then
lMaxRecord = 65536
Else
lMaxRecord = UBound(vReport, 2)
End If

With .Worksheets(1)
'Output the report to the remaining worksheet
.Range(.Cells(1, 1), _
.Cells(UBound(vReport) - LBound(vReport) + 1, _
UBound(vReport, 2) - LBound(vReport, 2) + 1)).Value = vReport
'Adjust the column widths
.UsedRange.Columns.AutoFit
End With

End With
Application.ScreenUpdating = True
End If

'clean up
Set FFolder = Nothing
Set wkbOutput = Nothing

End Sub

' Comments: This function returns an array of properties for
' all files in a folder and, optionaly, it sub-folders.
' This function will be called recursively if
' sub-folders are included.

Private Function FolderDetails(ByVal FolderPath As String, _
ByVal IncludeSubFolders As Boolean, _
ByRef FileProps As Variant, _
Optional ByVal FirstCall As Boolean = True) As Variant

Dim fsoFileSys As Scripting.FileSystemObject
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oSubFolder As Scripting.Folder
Dim vReturn As Variant
Dim vSubReturn As Variant
Dim lPropNum As Long
Dim sPropValue As String
Dim lSubRecord As Long

'Change the cursor to an hourglass
Application.Cursor = xlWait

'Create file system objects
Set fsoFileSys = New Scripting.FileSystemObject
Set oFolder = fsoFileSys.GetFolder(FolderPath)

'Set the initial size of the return array
ReDim vReturn(LBound(FileProps) To UBound(FileProps), 0)

'Add the Property headers to the return array
'Only if they have not yet been added
If FirstCall Then
For lPropNum = LBound(FileProps) To UBound(FileProps)
vReturn(lPropNum, 0) = FileProps(lPropNum)
Next lPropNum
End If

'Loop through each file in the folder
'adding its properties to the array
For Each oFile In oFolder.Files
'Increase the size of the array by one
ReDim Preserve vReturn(LBound(FileProps) To UBound(FileProps), UBound(vReturn, 2) + 1)

'Loop through the properties, adding each to the return array
For lPropNum = LBound(FileProps) To UBound(FileProps)

'Determine which file property to add
Select Case UCase(FileProps(lPropNum))
Case "NAME": sPropValue = oFile.Name
Case "DATECREATED": sPropValue = oFile.DateCreated
Case "DATELASTACCESSED": sPropValue = oFile.DateLastAccessed
Case "DATELASTMODIFIED": sPropValue = oFile.DateLastModified
Case "DRIVE": sPropValue = oFile.Drive
Case "PARENTFOLDER": sPropValue = oFile.ParentFolder
Case "PATH": sPropValue = oFile.Path
Case "SHORTNAME": sPropValue = oFile.ShortName
Case "SHORTPATH": sPropValue = oFile.ShortPath
Case "SIZE": sPropValue = oFile.Size
Case "TYPE": sPropValue = oFile.Type
Case "READONLY": sPropValue = HasAttribute(oFile, ReadOnly)
Case "HIDDEN": sPropValue = HasAttribute(oFile, Hidden)
Case "SYSTEM": sPropValue = HasAttribute(oFile, System)
Case "VOLUME": sPropValue = HasAttribute(oFile, Volume)
Case "DIRECTORY": sPropValue = HasAttribute(oFile, Directory)
Case "ARCHIVE": sPropValue = HasAttribute(oFile, Archive)
Case "ALIAS": sPropValue = HasAttribute(oFile, Alias)
Case "COMPRESSED": sPropValue = HasAttribute(oFile, Compressed)
Case Else: sPropValue = ""
End Select

'Add the property to the array
vReturn(lPropNum, UBound(vReturn, 2)) = sPropValue
Next lPropNum
Next oFile

'Do sub-folders need to be included?
If IncludeSubFolders Then

'loop through each sub-folder
For Each oSubFolder In oFolder.SubFolders

'Recursive call to this function
vSubReturn = FolderDetails(oSubFolder.Path, True, FileProps, False)

'Pass the values from the sub-call into the return array
For lSubRecord = 1 To UBound(vSubReturn, 2)
ReDim Preserve vReturn(LBound(FileProps) To UBound(FileProps), UBound(vReturn, 2) + 1)
For lPropNum = LBound(FileProps) To UBound(FileProps)
vReturn(lPropNum, UBound(vReturn, 2)) = vSubReturn(lPropNum, lSubRecord)
Next lPropNum
Next lSubRecord
Next oSubFolder
End If

'Return the array
FolderDetails = vReturn

'Clean up
Set oSubFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set fsoFileSys = Nothing
Application.Cursor = xlDefault

End Function

' Comments: This function determines if a file has a
' particular attribute

Function HasAttribute(ByRef CheckFile As Scripting.File, _
ByRef Attrib As Scripting.FileAttribute) As String
If CheckFile.Attributes And Attrib Then
HasAttribute = "Yes"
Else
HasAttribute = "No"
End If
End Function

' Comments: This function transposes a 2 dimension array

Function Transpose2DArray(ByRef OriginalArray As Variant) As Variant
Dim lLboundX As Long
Dim lUboundX As Long
Dim lLboundY As Long
Dim lUboundY As Long
Dim vaTemp() As Variant
Dim lXCounter As Long
Dim lYCounter As Long

lLboundX = LBound(OriginalArray)
lUboundX = UBound(OriginalArray)
lLboundY = LBound(OriginalArray, 2)
lUboundY = UBound(OriginalArray, 2)

ReDim vaTemp(lLboundY To lUboundY, lLboundX To lUboundX)

For lXCounter = lLboundX To lUboundX
For lYCounter = lLboundY To lUboundY
vaTemp(lYCounter, lXCounter) = OriginalArray(lXCounter, lYCounter)
Next lYCounter
Next lXCounter

Transpose2DArray = vaTemp
End Function