This query was posted in the below forums too
I have a code that successfully merges data from a specific named sheets of multiple workbooks into specific master workbook sheet.
However, the code merges empty rows too that have some sort of formatting in them. In my case, the source sheets have borderlines without any values in the rows. I tried using
SourceRange.Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats
but it fails to resolve the problem. Also, I noticed that the code fetches 527 rows of data from every sheet file with the exception of the 1st file in the folder. As I had manually cleared formatting from it for testing purposes.
If I manually clear the formatting from the source files, save the file and then run the code it works right. But that's not possible in real time scenario.
I have attached sample data (.Zip Folder)
A novice to VBA. Please help. Thanks in Advance.
Note1: Please change MyPath in the code.
Note2: RDM_Last Function is used to determine the last row with value. This entire code was taken from the following URL: https://www.rondebruin.nl/win/s3/win008.htm (In the bottom most section of the website)
The complete Code:
Sub MergeAllWorkbooks2() 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 ' The sheet name for the data to be copied to. Set BaseWks = ThisWorkbook.Sheets("Sheet3") rnum = 2 ' 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") 'Set sourceRange = .Range("A5:J104") 'End With With mybook.Worksheets("Defect Analysis Reports") FirstCell = "A5" Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells)) .Range(FirstCell & ":" & RDB_Last(3, .Cells)).ClearFormats 'Test if the row of the last cell >= then the row of the FirstCell 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 MsgBox "All Data has been merged successfully" End Sub