folders and subfolders exdatafiles copy from Sheet 1 and sheet 2 to Master file sheet 1 and sheet2

Topic

New Reply

Hi experts !
I have about 500 Excel files in folder and subfolders each excel file contains 2 sheets with same format .
I want to copy all 500 excel files data into one Master file ( master file contains two sheets same as data files).

I am attaching Datafile1-28-9-2016.xlsx and Datafile1-29-9-2016.xlsx which contains data to copy to Masterfile and results.xlsx( In master file how the results needs in available).

Samples attached

Reply | Quote

Replies

Farrukh,

The following code will allow the user to browse to the folder containing the source files. It will then append both worksheets of the files and those located in the subfolders to the master workbook. An assumption is made that the only Excel files in the folders/subfolders are the source files.

With 500 worksheets this is fairly labor intensive. So allow some time for the code to complete.

HTH,
Maud

Code:

Sub ListFiles()
[COLOR=”#008000″]’LISTFILES AND LISTMYFILES MODIFIED FROM
‘http://excelexperts.com/VBA-Tips-List-Files-In-A-Folder[/COLOR]
[COLOR=”#008000″]’——————————————————————–
‘DECLARE AND SET VARIABLES[/COLOR]
 Dim ShellApplication As Object
 On Error Goto errorhandler
 Set ShellApplication = CreateObject(“Shell.Application”).BrowseForFolder(0, “Please choose a folder”, 0, OpenAt)
 Path = ShellApplication.self.Path
 Set ShellApplication = Nothing
[COLOR=”#008000″] ‘——————————————————————–
 ‘DEFAULT PATH FROM HIDDEN SHEET[/COLOR]
 Call ListMyFiles(Path, True)
errorhandler:
 End Sub



Sub ListMyFiles(mySourcePath, IncludeSubfolders)
[COLOR=”#008000″]’——————————————————————–
‘DECLARE AND SET VARIABLES[/COLOR]
 Application.ScreenUpdating = False
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = ThisWorkbook
    Set MyObject = New Scripting.FileSystemObject
    Set mySource = MyObject.GetFolder(mySourcePath)
    Application.ScreenUpdating = False
[COLOR=”#008000″]’——————————————————————–
‘FIND XLSX FILES ONLY[/COLOR]
    For Each myfile In mySource.Files
        If UCase(Right(myfile.Name, 4)) = “XLSX” Then
            Nextrow1 = wb1.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Nextrow1 < 6 Then Nextrow1 = 6
            Nextrow2 = wb1.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
            If Nextrow2 < 6 Then Nextrow2 = 6
[COLOR="#008000"]'——————————————————————–
'OPEN FILE AND COPY TO MASTER[/COLOR]
            Application.Workbooks.Open myfile
            Set wb2 = ActiveWorkbook
            Lastrow1 = wb2.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
            Lastrow2 = wb2.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
            For I = 6 To Lastrow1
                For J = 1 To 28
                    wb1.Worksheets(1).Cells(Nextrow1, J) = wb2.Worksheets(1).Cells(I, J)
                Next J
                Nextrow1 = Nextrow1 + 1
            Next I
            For I = 6 To Lastrow2
                For J = 1 To 28
                    wb1.Worksheets(2).Cells(Nextrow2, J) = wb2.Worksheets(2).Cells(I, J)
                Next J
                Nextrow2 = Nextrow2 + 1
            Next I
        End If
        wb2.Close
    Next
[COLOR="#008000"]'——————————————————————–
'SEARCH SUBFOLDERS FOR SAME CRITERIA[/COLOR]
    If IncludeSubfolders Then
        For Each MySubFolder In mySource.SubFolders
            Call ListMyFiles(MySubFolder.Path, True)
        Next
    End If
Application.ScreenUpdating = True
End Sub


Public Sub Reset()
    Dim wb1 As Workbook, wb2 As Workbook
    Set wb1 = ThisWorkbook
    Nextrow1 = wb1.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
    If Nextrow1 < 6 Then Nextrow1 = 6
    Nextrow2 = wb1.Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
    If Nextrow2 < 6 Then Nextrow2 = 6
    wb1.Worksheets(1).Range("A6:AB" & Nextrow1).ClearContents
    wb1.Worksheets(2).Range("A6:AB" & Nextrow2).ClearContents
End Sub

Reply | Quote

Hi Sir Maudibe ,
The File provided by you works great . Well done :clapping::clapping:

Thanks you very much.

Reply | Quote