Macro Needed to Extract Data from Multiple Workbooks

[ThriftyBrewer]

Hi All,
I'm hoping I might be able to get some assistance with a macro. I searched the forums before posting, but I couldn't seem to find an existing post that addresses exactly what I need.

I have roughly 1,000 excel files, all stored in the same folder, from which I need to capture data and summarize on one sheet. Specifically, I would like each file to be represented as one row on the summary document, with the four data elements I'm looking to capture stored in columns A through D. On the worksheets I'm looking to extract from, the data I need is stored in cells B3, B35, B36, and B37. All the workbooks have different names, but the name of the sheet I want to pull the data from is the same for every file.

I greatly appreciate any assistance that anyone is able to offer. Please let me know if more detail is required.
Thanks!

 

[mancubus]

welcome to the forum.
try this

Sub mrxl_922184_parse_same_range_from_files()
    'adopted : http://www.vbaexpress.com/forum/showthread.php?55165-Merge-and-Append-95-Workbooks-into-One-Workbook
    
    Dim FilesInFolder, CopyCells
    
    FilesInFolder = Filter(Split(CreateObject("WScript.shell").Exec("cmd /c Dir C:\Users\Me\Documents\test\*.xls? /b/s").StdOut.ReadAll, vbCrLf), ".")
    'change C:\Users\Me\Documents\test\ to suit
    
    ReDim CopyCells(UBound(FilesInFolder) - 1, 3)
     
    For j = 0 To UBound(FilesInFolder) - 1
        With GetObject(FilesInFolder(j))
            With .Worksheets("Sheet1") 'Change Sheet1 to suit
                CopyCells(j, 0) = .Range("B3").Value
                CopyCells(j, 1) = .Range("B35").Value
                CopyCells(j, 2) = .Range("B36").Value
                CopyCells(j, 3) = .Range("B37").Value
            End With
            .Close 0
        End With
    Next

    Worksheets("SummarySheet").Cells(1).Resize(UBound(sp) + 1, 4) = CopyCells 'Change SummarySheet to suit

End Sub

 

[ThriftyBrewer]

Thanks very much for the quick reply. I tried running the above, and I received a "Run time error '7': Out of Memory."

I ran the debugger, and it highlighted the following bit of code, with a message indicating <Type Mismatch>:
ReDim CopyCells(UBound(FilesInFolder) - 1, 3)

I'm afraid I don't know enough to troubleshoot beyond that. If there's anything else you could do to help I would greatly appreciate it. Thanks again!

 

[ThriftyBrewer]

As a further clarification to the above, the message regarding that line of code was "type mismatch." It got removed when I submitted the reply. Thanks again.

 

[mancubus]

you are welcome.

my bad. i replaced the variable names in the original code for easy understanding. but it seems i missed one.

and since the array is filtered, "-1" in the loop is redundant.

try this:

Sub mrxl_922184_parse_same_range_from_files()
    'adopted : http://www.vbaexpress.com/forum/showthread.php?55165-Merge-and-Append-95-Workbooks-into-One-Workbook
    
    Dim FilesInFolder, CopyCells
    Dim j As Long
    
    FilesInFolder = Filter(Split(CreateObject("WScript.shell").Exec("cmd /c Dir C:\Users\Me\Documents\test\*.xls? /b/s").StdOut.ReadAll, vbCrLf), ".")
    'change C:\Users\Me\Documents\test\ to suit
    
    ReDim CopyCells(UBound(FilesInFolder), 3)
     
    For j = 0 To UBound(FilesInFolder)
        With GetObject(FilesInFolder(j))
            With .Worksheets("Sheet1") 'Change Sheet1 to suit
                CopyCells(j, 0) = .Range("B3").Value
                CopyCells(j, 1) = .Range("B35").Value
                CopyCells(j, 2) = .Range("B36").Value
                CopyCells(j, 3) = .Range("B37").Value
            End With
            .Close 0
        End With
    Next

    Worksheets("SummarySheet").Cells(1).Resize(UBound(CopyCells) + 1, 4) = CopyCells 'Change SummarySheet to suit

End Sub