Combine All Data From All Workbooks in a specified directory


Board Regular
Jul 29, 2002
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.

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).
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
GoTo myNxt

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

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

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
.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

Selection.Font.Bold = False

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

End With
Application.ScreenUpdating = True

MsgBox "No Excel WorkBooks found!"
End Sub
Upvote 0
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
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
.FileName = ".xls"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks

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 + _
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
End With

Set WB = Nothing
Set CurWks = Nothing

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub
Upvote 0

Forum statistics

Latest member

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back