This works for me
Sub mcrOMACopyAllWbInFolderToActiveSheet()
Dim cel As Range
Dim FileName, ws As Worksheet
Dim rng As Range
Dim destWB As Workbook
Dim pPath As String
Dim ShellApp As Object
Dim a As Variant
' Get user to select folder where the data you wish copied lies.
Set ShellApp = CreateObject("Shell.Application").BrowseForFolder(0, Prompt, 0, OpenAt)
On Error Resume Next
pPath = ShellApp.self.Path
On Error GoTo 0
' everything happens in this block, first check to see if the folder where the data
' resides was selected, then open a new workbook, loop through all files in folder
' and all sheets within each file, copying them to the newly created workbook
' so the data can be formatted for reporting.
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
If pPath = "" Then
' Cancel was selected
MsgBox "Stopping because you did not select a Folder"
Exit Sub
End If
LR = 1
' Add new workbook here
Workbooks.Add
Set destWB = ActiveWorkbook
With CreateObject("scripting.filesystemobject")
' Loop through all files in folder
For Each FileName In .getfolder(pPath).Files
With Workbooks.Open(FileName)
' Loop through all worksheets in workbook
For Each ws In .Sheets
a = ws.Range("a1:y20").Value
With destWB.Sheets(1)
.Cells(LR, 1).Resize(UBound(a), UBound(a, 2)) = a
.Cells(LR, "z").Resize(UBound(a)) = FileName.Name
LR = .Cells(Rows.Count, "a").End(xlUp).Row + 2
End With
Next
.Close
End With
Next
End With
Application.DisplayAlerts = 1
Application.ScreenUpdating = 1
End Sub
Bookmarks