How to collate all files from one folder in single file

[ThrottleWorks]

Hi,

I have a folder. In this folder, there will be approx. 50 files.

I want to collate all these files in one new file.

Data is present only in sheet 1 of all the files. Collated file will have a single row of headers from original files.

User will select this folder by browsing option provided in the macro.

How can I do it, can anyone please help me in this.

 

[Nebu]

Hi:

This is a macro I have written for Terry long back which seems to be your requirement. You can tweak the code as per your need.

http://forum.chandoo.org/threads/vba-pull-balances.24622/

Thanks

 

[ThrottleWorks]

Hi @Nebu sir, thanks a lot for the help. I am checking this and will revert with details.

Have a nice day ahead.

 

[PCosta87]

Hi @ThrottleWorks,

Something like this should work... it was made for columns A:D but can be changed to fit the exact range in question.
As it is, you just need to paste the code into the workbook you wish to copy the data to and you should be good to go.
I didn't transfer the headers from the files so you will need to fill the first row (either before or after running the code)

Sub OpenFiles()

    Application.ScreenUpdating = False
   
        Dim MyFolder As String
        Dim MyFile As String
        Dim wrkbk As String
       
        wrkbk = ActiveWorkbook.Name
       
        On Error Resume Next
        With Workbooks(wrkbk).Sheets(1)
            .Range("A2:D" & .Range("A2").End(xlDown).Row).ClearContents
        End With
       
        MyFolder = GetFolder("")
        MyFile = Dir(MyFolder & "\*.xlsx")
       
        Do While MyFile <> ""
            Workbooks.Open Filename:=MyFolder & "\" & MyFile
            MyFile = Dir
           
            With ActiveWorkbook.Sheets(1)
                Range("A2:D" & Range("A2").End(xlDown).Row).Copy Workbooks(wrkbk).Sheets(1).Cells(Workbooks(wrkbk).Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
                ActiveWorkbook.Close savechanges:=False
            End With
        Loop
   
    Application.ScreenUpdating = True

End Sub

Function GetFolder(strPath As String) As String

    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
   
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With

NextCode:
    GetFolder = sItem
    Set fldr = Nothing

End Function

Hope it helps

Regards

 

[ThrottleWorks]

Hi @PCosta87 sir, thanks a lot for the help. Am checking this and will revert with details.

Have a nice day ahead.