Macro to join together data from multiple workbooks into one sheet


New Member
Jul 21, 2015
Hi all,

I have a query in that I'd like a macro to open each workbook in a folder and copy the data into one new accumulative workbook. The data in each of the workbooks are similar and have the same headings.
For a bonus I also have the following code to add that will then label where the data is from based on it's filename in the folder.
Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the title of a string up to but not including the rightmost '\'

If Right$(strPath, 1) <> "" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function

Any help would be much appreciated.

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number


New Member
Jul 21, 2015
Here's most of my solution if anyone has a similar query.

'Define variables to be copied from
Dim Certificate_Number As String
Dim Postcode As String
Dim Commissioning_Date As Date
Dim Overall_Cost_of_Renewable_Technology As Double
Dim First_Registration_Date As Date
Dim Tech As String
Dim MyFolder As String
Dim MyFile As String
Dim lastRow As Long
'define the folder path where all of the returns are stored.
'This is specified in the Macro worksheet
MyFolder = Range("c2").Value
'Opens file in folder
MyFile = Dir(MyFolder & "\*.csv")
Do While MyFile <> ""
    Workbooks.Open Filename:=MyFolder & "\" & MyFile
    MyFile = Dir
'Labels Tech column
Range("AL1") = "Tech"
'Gets Tech type from filename and fills out tech column
strFileFullName = ActiveWorkbook.FullName
Range("AM1").Value = strFileFullName
Range("AL2").Formula = "=IF(ISNUMBER(SEARCH(""*Micro CHP*"",AM1)),""MICRO CHP"",IF(ISNUMBER(SEARCH(""*Solar PV*"",AM1)),""PV"",IF(ISNUMBER(SEARCH(""*Wind Turbine*"",AM1)),""WIND TURB"",""""))) "
Range("AL2").PasteSpecial xlPasteValues
lastRow = Range("AK" & Rows.Count).End(xlUp).Row
Range("AL2").AutoFill Destination:=Range("AL2:AL" & lastRow)

'Copies relevant data to Combined Data sheet in Clean MCS Data workbook
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim range4 As Range
Dim range5 As Range
Dim range6 As Range
Dim range7 As Range
Dim multipleRange As Range
Set range1 = Range("A2:A300000")
Set range2 = Range("F2:F300000")
Set range3 = Range("L2:L300000")
Set range4 = Range("S2:S300000")
Set range5 = Range("Y2:Y300000")
Set range6 = Range("AK2:AK300000")
Set range7 = Range("AL2:AL300000")
Set multipleRange = Union(range1, range2, range3, range4, range5, range6, range7)
'Closes workbook, doesn't save, but saves copied data to clipboard
Application.DisplayAlerts = False
Application.DisplayAlerts = True
'Pastes data to bottom of Combined Data sheet
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & lastRow + 1).Select
'Loops to next file in folder
Upvote 0


New Member
Dec 22, 2016
I create a list and go through sub folders using this. Once I have the list I go down the list using the cell value for the file name to open the file and copy the data. You can use .offset and .resize to avoid selecting in the opened files and speed up the copying using variables instead of .select

Option Explicit
Sub RecursiveFolder(objFolder As Scripting.Folder, IncludeSubFolders As Boolean)

Dim objFile As Scripting.File
Dim objSubFolder As Scripting.Folder
Dim NextRow As Long

NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1

For Each objFile In objFolder.Files
Cells(NextRow, "A").Value = objFile.Name
'Cells(NextRow, "F").Value = objFile.DateLastModified
NextRow = NextRow + 1
Next objFile

If IncludeSubFolders Then
For Each objSubFolder In objFolder.SubFolders
Call RecursiveFolder(objSubFolder, True)
Next objSubFolder
End If

End Sub

Then for resizing your selection to the unknown report length of each file
Dim LastRow As Long

'put this in the loop where the file is opened
LastRow = Range("column letter which goes the full report length" & Rows.Count).End(xlUp).Row

Range("A1").Resize(LastRow, "report column count").copy
'change to Range("A2").resize(LastRow - 1, "report column count").copy for reports 2 through the last to skip the headers.

When pasting you can add
LastRow = ...
Range("A1").offset(LastRow, 0).select 'to go to the unknown bottom of the report and then paste
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