Combine All Data From All Workbooks in a specified directory

[hemsleysut]

I have 79 workbooks in a directory, each with a worksheet called "Survey Report" - all with the same structure. Every "Survey Report" worksheet is identified by an unique entry in the cell A10 and has data entered in the range B12:N23. I would like to put all the data from all the worksheets into one master worksheet together with the identifier. Any help would be greatly appreciated.

 

[Joe Was]

This code asks you for the folder to search. Gets each Workbooks name in that folder and adds it's name to a Sheet named "List" [if missing it makes the "List" sheet.] you need to add the code to work with the sheets in the Workbooks [I added a comment to where that code needs to go!].


Sub Look_In_x()
Dim lngCellCounter As Long
Dim Message, Title, Default, MyDir, DirNM
'Search current directory for all files.

On Error GoTo mkSh
Sheets("List").Select
GoTo myNxt

mkSh:
For Each sh In Worksheets
i = i + 1
Next sh

With Sheets.Add
.Name = "List"
.Move After:=Sheets(i + 1)
End With

myNxt:
Application.ScreenUpdating = False
Message = "Enter the directory to search?" & vbCrLf & vbCrLf & "(Drive:\Directory\SubDirectory)" ' Set prompt.
Title = "Enter: Drive and Path!" ' Set title.
Default = "C:\MY FILES\JSW\Excel\" ' Set default.
' Display message, title, and default value.
On Error GoTo myErr

MyDir = InputBox(Message, Title, Default)

With Application.FileSearch
.NewSearch
.FileType = msoFileTypeExcelWorkbooks
.LookIn = MyDir
.SearchSubFolders = True
If .Execute() > 0 Then

'MsgBox "There were " & .FoundFiles.Count & " file(s) found."

For lngCellCounter = 1 To .FoundFiles.Count
Cells(lngCellCounter, 1) = .FoundFiles(lngCellCounter)

'Add code for working with each Workbook here!

Next lngCellCounter

Sheets("List").Select
Range("A1").Select
Columns("A:A").Select
Selection.Font.Bold = False
Range("A1").Select

DirNM = "The Files for: " & MyDir & " are:"
Selection.EntireRow.Insert
Sheets("List").Range("A1").Value = DirNM
Sheets("List").Range("A2").Select
Selection.EntireRow.Insert
Sheets("List").Range("A1").Select
Selection.Font.Bold = True
Else
MsgBox "No Excel WorkBooks found!"
End If

End With
Application.ScreenUpdating = True
End
myErr:

MsgBox "No Excel WorkBooks found!"
End Sub

 

[hemsleysut]

Found the code below on the forum which is almost exactly what I need. But the change I need to make is that the data in all the files I am processing are in the range B12:K24 with the headers in the range B11:K11. Can anyone suggest how the code can be altered. Thanks in advance for any assistance.

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