Export to multiple workbooks - row limit

[James Stephens]

This is along the lines of a previous post, but different enouph to post in a new thread, I think. Here is my situation. I have the following code worked out. It takes a workbook of multiple pages and breaks it out into multiple workbooks based on the date of the data in each row. Those dates come from a list in another workbook

Sub Test2(
Application.ScreenUpdating = Fals
Application.DisplayAlerts = Fals
Dim MyPath As Strin
Dim sh As Workshee
Dim i As Lon
Dim cLastRow As Lon
Windows("TIPSData.xls").Activat
Sheets("DateSheet").Selec
Set sh = ActiveWorkbook.ActiveShee

cLastRow = Cells(Rows.Count, "A").End(xlUp).Ro
For i = 1 To cLastRo
MonthlyFiles Left(sh.Cells(i, "A").Value, Len(sh.Cells(i, "A").Value)
Next

End Su

Sub MonthlyFiles(Month As String
Dim ws As Workshee
'Creat
Workbooks.Ad
Sheets("Sheet2").Selec
ActiveWindow.SelectedSheets.Delet
Sheets("Sheet3").Selec
ActiveWindow.SelectedSheets.Delet
With ActiveWorkboo
.SaveAs FileName:=ThisWorkbook.Path
& "\ProgramData\FileData\ConvertedData\Monthly\Report4\" & Month & ".xls",
FileFormat:=xlNormal,
Password:="",
WriteResPassword:="",
ReadOnlyRecommended:=False,
CreateBackup:=Fals
End Wit
Windows("Report4.xls").Activat
For Each ws In ActiveWorkbook.Worksheet
ws.Activat
With w
.Columns("A:R").AutoFilter Field:=10, Criteria1:=Mont
.Columns("A:R").SpecialCells(xlCellTypeVisible).Cop
Windows(Month & ".xls").Activat
LastRow = Cells(Rows.Count, "A").End(xlUp).Ro
Range("A" & LastRow + 1).PasteSpecia
Windows("Report4.xls").Activat
End Wit
Next w
End Su

My two issues are, is there a way in the bottom portion where I copy all visable cells into the new workbook with only one worksheet (since I remove the others). Is there a way to make this so that if the total amount of data exceeds the row limit, then it will create a new page and paste into that? I asked a similar question before and got the following code, but can't figure out a way to merge these two. I am working on it, but so far no luck

Option Explici
Sub CombineWorkbooks(

Dim LastRow As Lon
Dim basebook As Workboo
Dim i As Lon
Dim mybook As Workboo
Dim DestCell As Rang
Dim RngToCopy As Rang

With Applicatio
.DisplayAlerts = Fals
.EnableEvents = Fals
.ScreenUpdating = Fals
End Wit

With Application.FileSearc
.NewSearc
'Change this to your director
.LookIn = ThisWorkbook.Path & "\ProgramData\"
.SearchSubFolders = Fals
.FileType = msoFileTypeExcelWorkbook
If .Execute() > 0 The
Set basebook = Workbooks.Open(.FoundFiles(1)

With basebook.Worksheets(1
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp
End Wit

For i = 2 To .FoundFiles.Coun
Set mybook = Workbooks.Open(.FoundFiles(i)
With ActiveShee
'column R = 18th colum
Set RngToCopy = .Range("a1:R" &
.Cells(.Rows.Count, "A").End(xlUp).Row
End Wit

If (DestCell.Row + RngToCopy.Rows.Count)
< DestCell.Parent.Rows.Count The
'ok to paste, just come down one
Set DestCell = DestCell.Offset(1, 0
Els
'too many rows, make a new shee
Set DestCell = basebook.Worksheets.Add.Range("a1"
End I

RngToCopy.Copy
Destination:=DestCel
Set DestCell = DestCell.Offset(RngToCopy.Rows.Count
mybook.Clos
Next
'ChDir ThisWorkbook.Path & "\ProgramData\FileData\Report\
ActiveWorkbook.SaveAs
Filename:=ThisWorkbook.Path & "\ProgramData\FileData\Report\"
& "Report1.xls", _
FileFormat:=xlText, CreateBackup:=False

'ActiveWorkbook.Close savechanges:=false 'just saved
End If
End With

With Application
.DisplayAlerts = True
.EnableEvents = True
End With

End Sub


Also is there a way to not copy and paste the column headers?

Thanks for your assistance

Jim