Results 1 to 3 of 3
  1. #1
    2 Star Lounger
    Join Date
    Jun 2011
    Posts
    188
    Thanks
    62
    Thanked 0 Times in 0 Posts

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

    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
    Attached Files Attached Files
    Last edited by farrukh; 2016-09-30 at 12:10. Reason: Attached the samples

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,640
    Thanks
    115
    Thanked 651 Times in 593 Posts
    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()
    'LISTFILES AND LISTMYFILES MODIFIED FROM
    'http://excelexperts.com/VBA-Tips-List-Files-In-A-Folder
    '--------------------------------------------------------------------
    'DECLARE AND SET VARIABLES
     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
     '--------------------------------------------------------------------
     'DEFAULT PATH FROM HIDDEN SHEET
     Call ListMyFiles(Path, True)
    errorhandler:
     End Sub
    
    
    
    Sub ListMyFiles(mySourcePath, IncludeSubfolders)
    '--------------------------------------------------------------------
    'DECLARE AND SET VARIABLES
     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
    '--------------------------------------------------------------------
    'FIND XLSX FILES ONLY
        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
    '--------------------------------------------------------------------
    'OPEN FILE AND COPY TO MASTER
                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
    '--------------------------------------------------------------------
    'SEARCH SUBFOLDERS FOR SAME CRITERIA
        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
    Attached Files Attached Files
    Last edited by Maudibe; 2016-10-03 at 01:36. Reason: Provide credit for ListFiles code

  3. The Following User Says Thank You to Maudibe For This Useful Post:

    farrukh (2016-10-03)

  4. #3
    2 Star Lounger
    Join Date
    Jun 2011
    Posts
    188
    Thanks
    62
    Thanked 0 Times in 0 Posts
    Hi Sir Maudibe ,
    The File provided by you works great . Well done

    Thanks you very much.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •