How to extract the same 5 celss from multiple excell work books and display them in rows

[FlyCoho]

I have a folder with a few hundred Excell workbooks. All the formatting is the same in each workbook. How do I extract 5 cells from each workbook without manually openig them up? I would like to list them 5 colums wide by a few hundreds rows of the data. Thanks for your help.

 

[pushkardey]

Descrition : Copy specific range from all files in a folder.

Sub BrowseForFolder()
Set w = ThisWorkbook
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, "Select", 0, OpenAt)
    On Error GoTo Invalid
fldrpth = ShellApp.self.Path & "\"
Set ShellApp = Nothing
shtnm = InputBox("Give sheet name")
'if you dont want to give a particular name of the sheet
'and want to use a sheet index i.e. number of the sheet like first sheet
'then you will have to comment the above line of code and substitute "shtnm" with the worksheet number
Rng = InputBox("Give Range to copy from each sheet")
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldrnm = CreateObject("scripting.FilesystemObject").GetFolder(fldrpth).Files
k = fso.GetFolder(fldrpth).Files.Count
shtnm_w = "Sheet1" 'change "Sheet1" to worksheet name to where you want to paste the data
w.Sheets(shtnm_w).Cells.Clear
For Each f In fldrnm
    Application.Workbooks.Open Filename:=f.Path
    Set w1 = Application.Workbooks(f.Name)
    
    w1.Sheets(shtnm).Activate
    w1.Sheets(shtnm).Range(Rng).Copy
    
    lstrw_w = Application.WorksheetFunction.CountA(w.Sheets(shtnm_w).Range("A:A")) + 1
    w.Sheets(shtnm_w).Range("A" & lstrw_w).PasteSpecial Paste:=xlValues
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    w1.Close
Next
w.Save
Exit Sub
Invalid:
    MsgBox "No Folder Selected"
    fldrpth = False
End Sub

Hope this helps

 

[FlyCoho]

Re: How to extract the same 5 cells from multiple excell work books and display them in rows

Thanks for your help. I will give it a try.

FlyCoho