Option Explicit
Function PickFolder(strStartDir As Variant) As String
Dim SA As Object, F As Object
Set SA = CreateObject("Shell.application")
Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not F Is Nothing) Then
PickFolder = F.items.Item.Path
End If
Set F = Nothing
Set SA = Nothing
End Function
Sub CopySheetFromMultipleFiles()
Dim lrow As Long
Dim Hdrs As Long
Dim NumCols As Long
Dim ffc As Long
Dim i As Long
Dim R As Integer
Dim WBn As String
Dim rng As Range
Dim WB As Workbook
Dim WBr As Range
Dim WBlstrw As Long
Dim CurWks As Worksheet
Dim CurWksLrow As Long
Dim strStartDir As String
Dim UserFile As String
Dim Sht As Worksheet
On Error Resume Next
UserFile = PickFolder(strStartDir)
If UserFile = "" Then
MsgBox "Canceled"
Exit Sub
End If
'CurWks will always refer to the Summary worksheet you are creating
Set CurWks = ActiveWorkbook.Worksheets("Summary")
Application.ScreenUpdating = False
'Clear out the Summary worksheet
CurWks.Activate
With CurWks
CurWksLrow = .Cells(Rows.Count, "A").End(xlUp).Row
If CurWksLrow > 1 Then
.Cells(2, 1).Resize(CurWksLrow - 1, 1).EntireRow.Delete
End If
End With
lrow = 1
Hdrs = 1
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
.Filename = ".xls"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute
ffc = .FoundFiles.Count
For i = 1 To ffc
'WB will always refer to the source Workbook that you
'are interrogating at the time
Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i))
If i = 1 Then
NumCols = WB.Sheets(1).UsedRange.Column - 1 + _
WB.Sheets(1).UsedRange.Columns.Count
End If
Application.StatusBar = "Currently Processing file " & i & " of " & ffc
WBn = WB.Name
WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
'Copy the data across
CurWks.Cells(lrow + 1, "B").Resize(WBlstrw - Hdrs, NumCols).Value = _
WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value
'Put the filename in the first Col as an index value
CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn
lrow = lrow + (WBlstrw - Hdrs)
WB.Close savechanges:=False
Next
End With
Set WB = Nothing
Set CurWks = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub