Combining data from multiple workbooks

Hi Steve,

Thank you for the forum question and the nice feedback yesterday.

The code below will do what you need. You may need to amend it. The code is copy and pasting all records for any number of workbooks stored in a folder, but the only from sheet 1 in the source workbooks. The lists in sheet 1 all starts from row 1.

You can change the line below, if you do not have the data in sheet1 and change Range("a1") if your list do not starts from A!:

varAllData=WorkBk.Sheets(1).Range("a1").CurrentRegion.Offset(1, 0)

You will need to change the line below as well. Change "Destination" to the name of your destination sheet.

ThisWorkbook.Sheets("Destination").Activate

Copy the code below and paste it in the destination workbook.

Option Explicit
Sub MergeAllWorkbooks()
Dim FolderPath As String 'store the folderpath in the computer's memory
Dim FileName As String 'store the file name inthe computer's memory
Dim WorkBk As Workbook 'store the name of each workbook in the computer's memory
Dim blankrow As Integer 'store the row number of the first blank row in destination sheet
Dim varAllData As Variant 'array. Will store all records from the source workbooks

Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then '-1 = yes or true
FolderPath = .SelectedItems(1) & "\"
Else
MsgBox "FilePath not selected!", , "Path selecter"
Exit Sub
End If
End With
FileName = Dir(FolderPath & "*.xl*")
Do While FileName <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileName)
varAllData = WorkBk.Sheets(1).Range("a1").CurrentRegion.Offset(1, 0)
ThisWorkbook.Sheets("Destination").Activate
blankrow = Range("a1").CurrentRegion.Rows.Count + 1
Range("A" & blankrow).Resize(UBound(varAllData, 1), UBound(varAllData, 2)) = varAllData
WorkBk.Close savechanges:=False
FileName = Dir()
Loop
Columns.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True

end Sub




Kind regards

Jens Bonde
Microsoft Office Specialist Trainer

Tel: 0207 987 3777
Best STL - https://www.stl-training.co.uk
98%+ recommend us

London's leader with UK wide delivery in Microsoft Office training and management training to global brands, FTSE 100, SME's and the public sector