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.
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
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)
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!