I have a macro that consolidates data from a specific sheet in multiple workbooks to a single sheet in a new workbook.
The code goes through each sheet called "input sheet" in the workbooks and adds new data at the bottom of the other data.
The issue I have is that the source data in the sheets is not hard coded, but formula based. There are 150 rows and the data filled in varies from workbook to workbook. When the code gets to the end of the data, it does not recognize the blank ("") that I have through formulas and takes all 150 rows regardless if they are filled or not.
How can I alter this to not get the extra blank rows?
The code goes through each sheet called "input sheet" in the workbooks and adds new data at the bottom of the other data.
The issue I have is that the source data in the sheets is not hard coded, but formula based. There are 150 rows and the data filled in varies from workbook to workbook. When the code gets to the end of the data, it does not recognize the blank ("") that I have through formulas and takes all 150 rows regardless if they are filled or not.
How can I alter this to not get the extra blank rows?
Code:
Sub MergeSpecificWorkbooks() 'http://www.rondebruin.nl/copy3.htm
Dim MyPath 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
Dim SaveDriveDir As String
Dim FName As Variant
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'SaveDriveDir = CurDir
'ChDirNet "C:\Users\LNLD\Desktop\TEST VBA for consolidation"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Set BaseWks = Worksheets.Add
'BaseWks.Name = "Master"
rnum = 2
'Loop through all files in the array(myFiles)
For FNum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets("INPUT SHEET")
.Unprotect
LC = .Cells(.Rows.Count, "C").End(xlUp).Row
Set sourceRange = .Range("AJ2:CI" & LC)
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use 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 "Sorry there are not enough rows in the sheet"
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 = FName(FNum)
'End With
'Set the destrange
Set destrange = BaseWks.Range("A" & rnum)
'we copy the values from the sourceRange to the destrange
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 ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
' ChDirNet SaveDriveDir
End Sub
'Formatting tags added by mark007