trouble with VBA code to merge workbooks

[ldldc]

I'm using Ron de Bruin's code for merging workbooks and have modified a couple things. For one, I changed the code so that rather than open a new blank worksheet, I want to use the already open excel file in which I have some custom headings, not the headings from the worksheets I'm merging. Everything works great but one little detail...the merged data shows up in cell A10 but I'd prefer it to show up in cell A2, right under my headings. Any ideas?

Here is the code I'm using and have modified:

MergeAllWorkbooks()
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


MyPath = "Z:\Documentation\Project Tracking\Project Spreadsheets"


If Right(MyPath, 1) <> "" Then
MyPath = MyPath & ""
End If


FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With


Set BaseWks = ThisWorkbook.Worksheets("Project Summary")



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


With mybook.Worksheets("For Master Tracker")
Set sourceRange = .Range("A2:D5")
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else

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


Set destrange = BaseWks.Range("A1" & rnum)

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:

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

 

[wideboydixon]

Two problems that I can see. First, you're missing a line in the code:

Set BaseWks = ThisWorkbook.Worksheets("Project Summary")
rnum = 2

Second, this:

Set destrange = BaseWks.Range("A1" & rnum)

Should be this:

Set destrange = BaseWks.Range("A" & rnum)

WBD

 

[ldldc]

Amazing! I didn't realize those were connected. Thanks so much!