Merge Data from Multiple Workbooks into a Master Workbook

  • Hi,


    This is my first post, so hoping I get it right.


    I came across tons of solutions to my question but I failed to wrap my head around them to adapt it to my scenario. 2 days Old to VBA so please excuse


    What I need to achieve


    Note: On running the script, I will need to get a Browse Folder Pop-up to help navigate to the right sub-folder


    1) A Parent folder contains : One Child Folder by the name: Raw Data Month wise and the Master Workbook called : Org Level Defect Report - 2018
    2) The Child Folder has a Sub Folder Called : Jan-2018 (As of now. New folders will be added as Feb-2018, Mar-2018, etc)
    3) I need to import data from all the workbooks from the Sub Folder : Jan-2018 (As of now)
    4) Each workbooks Name starts with a code and followed by underscore symbol (CNS_Defect_Analysis_Report) (Need to fetch ONLY the code)
    5) Every workbook has the sheet: Defect Analysis Reports from which data between the Range A5:J (Check for last Row) should be fetched
    6) All the data should be pasted into the Master Workbook: Org Level Defect Report - 2018 into Sheet Name: Sheet2 . Starting from B Column (Last Available Row. Add new rows if no sufficient rows are available)
    7) And in Column A, the Code from the filename is pasted against all the data fetched from that file.
    8) MsgBox "All data has been Merged Successfully!"


    The following URL from MSDN has the related solution that I cannot follow: https://msdn.microsoft.com/en-us/lib...ffice.12).aspx


    EDIT


    Ok,


    I managed 50% of what I intend to achieve as stated in the question. The below code needs the following changes to get the desired result.


    1. It does not show the Browse Folder Pop-up


    2. The code makes a new workbook and pastes the data in it. However...
    2A. I need the data in the same master workbook (Org Level Defect Report - 2018) that the code is executed from and in Sheet : Sheet2. The First Cell would be A2 that will have the 3 letters File name then followed by the fetched data.


    3. The first Colum is the entire File name
    3A. I just need the FIRST 3 Letters of the file name Only


    4. The data pasted resizes the column widths / row heights
    4A. I need to keep the Destination Format as is


    5. The data fetched from the Source files is the entire defined sheet
    5A. However, the code should fetch only from Range - A5:J (Last Row should be identified)




    Code:

    Code
    Sub MergeAllWorkbooks()     Dim FirstCell As String     Dim MyPath As String, FilesInPath As String     Dim MyFiles() As String     Dim SourceRcount As Long, FNum As Long     Dim mybook As Workbook, BaseWks As Worksheet     Dim sourceRange As Range, destrange As Range     Dim rnum As Long, CalcMode As Long      ' Change this to the path\folder location of your files.     MyPath = "C:\Users\zatin.dharmapuri\Desktop\3. 2018\Raw Data Month wise\Jan-2018"      ' Add a slash at the end of the path if needed.     If Right(MyPath, 1) <> "\" Then         MyPath = MyPath & "\"     End If      ' If there are no Excel files in the folder, exit.     FilesInPath = Dir(MyPath & "*.xl*")     If FilesInPath = "" Then         MsgBox "No files found"         Exit Sub     End If      ' Fill the myFiles array with the list of Excel files     ' in the search folder.     FNum = 0     Do While FilesInPath <> ""         FNum = FNum + 1         ReDim Preserve MyFiles(1 To FNum)         MyFiles(FNum) = FilesInPath         FilesInPath = Dir()     Loop      ' Set various application properties.     With Application         CalcMode = .Calculation         .Calculation = xlCalculationManual         .ScreenUpdating = False         .EnableEvents = False     End With      ' Add a new workbook with one sheet.     Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)     rnum = 1      ' Loop through all files in the myFiles array.     If FNum > 0 Then         For FNum = LBound(MyFiles) To UBound(MyFiles)             Set mybook = Nothing             On Error Resume Next             Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))             On Error GoTo 0              If Not mybook Is Nothing Then                 On Error Resume Next                  ' Change this range to fit your own needs.                 With mybook.Worksheets("Defect Analysis Reports")                     FirstCell = "A5"                     Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))                     ' Test if the row of the last cell is equal to or greater than the row of the first cell.                     If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then                             Set sourceRange = Nothing                         End If                     End With                  If Err.Number > 0 Then                     Err.Clear                     Set sourceRange = Nothing                 Else                     ' If source range uses all columns then                     ' skip this file.                     If sourceRange.Columns.Count >= BaseWks.Columns.Count Then                         Set sourceRange = Nothing                     End If                 End If                 On Error GoTo 0                  If Not sourceRange Is Nothing Then                      SourceRcount = sourceRange.Rows.Count                      If rnum + SourceRcount >= BaseWks.Rows.Count Then                         MsgBox "There are not enough rows in the target worksheet."                         BaseWks.Columns.AutoFit                         mybook.Close savechanges:=False                         GoTo ExitTheSub                     Else                          ' Copy the file name in column A.                         With sourceRange                             BaseWks.Cells(rnum, "A"). _                                     Resize(.Rows.Count).Value = MyFiles(FNum)                         End With                          ' Set the destination range.                         Set destrange = BaseWks.Range("B" & rnum)                          ' Copy the values from the source range                         ' to the destination range.                         With sourceRange                             Set destrange = destrange. _                                             Resize(.Rows.Count, .Columns.Count)                         End With                         destrange.Value = sourceRange.Value                          rnum = rnum + SourceRcount                     End If                 End If                 mybook.Close savechanges:=False             End If          Next FNum         BaseWks.Columns.AutoFit     End If  ExitTheSub:     ' Restore the application properties.     With Application         .ScreenUpdating = True         .EnableEvents = True         .Calculation = CalcMode     End With End Sub


    Thanks in Advance!

  • Ok,


    I managed 50% of what I intend to achieve as stated in the question. The below code needs the following changes to get the desired result.


    1. It does not show the Browse Folder Pop-up


    2. The code makes a new workbook and pastes the data in it. However...
    2A. I need the data in the same master workbook (Org Level Defect Report - 2018) that the code is executed from and in Sheet : Sheet2. The First Cell would be A2 that will have the 3 letters File name then followed by the fetched data.


    3. The first Colum is the entire File name
    3A. I just need the FIRST 3 Letters of the file name Only


    4. The data pasted resizes the column widths / row heights
    4A. I need to keep the Destination Format as is


    5. The data fetched from the Source files is the entire defined sheet
    5A. However, the code should fetch only from Range - A5:J (Last Row should be identified)


    The Code:


    Code
    Sub MergeAllWorkbooks()    Dim FirstCell As String    Dim MyPath As String, FilesInPath As String    Dim MyFiles() As String    Dim SourceRcount As Long, FNum As Long    Dim mybook As Workbook, BaseWks As Worksheet    Dim sourceRange As Range, destrange As Range    Dim rnum As Long, CalcMode As Long    ' Change this to the path\folder location of your files.    MyPath = "C:\Users\zatin.dharmapuri\Desktop\3. 2018\Raw Data Month wise\Jan-2018"    ' Add a slash at the end of the path if needed.    If Right(MyPath, 1) <> "\" Then        MyPath = MyPath & "\"    End If    ' If there are no Excel files in the folder, exit.    FilesInPath = Dir(MyPath & "*.xl*")    If FilesInPath = "" Then        MsgBox "No files found"        Exit Sub    End If    ' Fill the myFiles array with the list of Excel files    ' in the search folder.    FNum = 0    Do While FilesInPath <> ""        FNum = FNum + 1        ReDim Preserve MyFiles(1 To FNum)        MyFiles(FNum) = FilesInPath        FilesInPath = Dir()    Loop    ' Set various application properties.    With Application        CalcMode = .Calculation        .Calculation = xlCalculationManual        .ScreenUpdating = False        .EnableEvents = False    End With    ' Add a new workbook with one sheet.    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)    rnum = 1    ' Loop through all files in the myFiles array.    If FNum > 0 Then        For FNum = LBound(MyFiles) To UBound(MyFiles)            Set mybook = Nothing            On Error Resume Next            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))            On Error GoTo 0            If Not mybook Is Nothing Then                On Error Resume Next                ' Change this range to fit your own needs.                With mybook.Worksheets("Defect Analysis Reports")                    FirstCell = "A5"                    Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))                    ' Test if the row of the last cell is equal to or greater than the row of the first cell.                    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then                            Set sourceRange = Nothing                        End If                    End With                If Err.Number > 0 Then                    Err.Clear                    Set sourceRange = Nothing                Else                    ' If source range uses all columns then                    ' skip this file.                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then                        Set sourceRange = Nothing                    End If                End If                On Error GoTo 0                If Not sourceRange Is Nothing Then                    SourceRcount = sourceRange.Rows.Count                    If rnum + SourceRcount >= BaseWks.Rows.Count Then                        MsgBox "There are not enough rows in the target worksheet."                        BaseWks.Columns.AutoFit                        mybook.Close savechanges:=False                        GoTo ExitTheSub                    Else                        ' Copy the file name in column A.                        With sourceRange                            BaseWks.Cells(rnum, "A"). _                                    Resize(.Rows.Count).Value = MyFiles(FNum)                        End With                        ' Set the destination range.                        Set destrange = BaseWks.Range("B" & rnum)                        ' Copy the values from the source range                        ' to the destination range.                        With sourceRange                            Set destrange = destrange. _                                            Resize(.Rows.Count, .Columns.Count)                        End With                        destrange.Value = sourceRange.Value                        rnum = rnum + SourceRcount                    End If                End If                mybook.Close savechanges:=False            End If        Next FNum        BaseWks.Columns.AutoFit    End IfExitTheSub:    ' Restore the application properties.    With Application        .ScreenUpdating = True        .EnableEvents = True        .Calculation = CalcMode    End WithEnd Sub[/B][B]

    [/B]

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!