Macro to join together data from multiple workbooks into one sheet

[nj2406]

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.

 

[nj2406]

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").Copy
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)
multipleRange.Copy
'Closes workbook, doesn't save, but saves copied data to clipboard
Application.DisplayAlerts = False
ActiveWindow.Close
Application.DisplayAlerts = True
'Pastes data to bottom of Combined Data sheet
ThisWorkbook.Activate
Sheets("CombinedData").Select
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & lastRow + 1).Select
ActiveSheet.Paste
'Loops to next file in folder
Loop

 

[GAdamWTW]

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