how to consolidate two ranges in a new workbook

[Dave F]

I have a report downloaded from a server, spread over two sheets,
Sheet1 and Sheet2 (the data runs to about 100,000 rows; I'm using XL
2003)

I want to run Advanced filter on both sheets and copy the filtered
records on both sheets and paste them into a new workbook.

Both sheets contain the same number of columns but a different number
of rows.

I've figured out how to do everything *except* how to copy and paste
the two separate ranges into one consolidated range in the new
workbook. So, following is the code I have:

Option Explicit
Sub FilterFAS()
Dim myFileName As String, myRow As Long, myRow2 As Long, myRow3 As
Long
Dim myRow4 As Long, myRow5 As Long, myRow6 As Long

If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.ShowAllData
End If

myRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
myRow2 = Sheet1.Cells(Rows.Count, 40).End(xlUp).Row
myRow3 = Sheet1.Cells(Rows.Count, 42).End(xlUp).Row
myRow4 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
myRow5 = Sheet2.Cells(Rows.Count, 40).End(xlUp).Row
myRow6 = Sheet2.Cells(Rows.Count, 42).End(xlUp).Row
Sheet1.Range("A1:AL" & myRow).AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=Sheet1.Range("AN1:AN" & myRow2),
CopyToRange:=Sheet1.Range("AP1"), Unique:=False
Sheet2.Range("A1:AL" & myRow4).AdvancedFilter Action:=xlFilterCopy,
CriteriaRange:=Sheet2.Range("AN1:AN" & myRow5),
CopyToRange:=Sheet2.Range("AP1"), Unique:=False
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
myFileName = Application.GetSaveAsFilename
If myFileName = False Then
Exit Sub
End If
ActiveWorkbook.SaveAs Filename:=myFileName,
FileFormat:=xlWorkbookNormal
End Sub

 

[Tom Ogilvy]

Option Explicit
Sub FilterFAS()
Dim myFileName As String, myRow As Long, _
myRow2 As Long, myRow3 As Long
Dim myRow4 As Long, myRow5 As Long, myRow6 As Long
Dim bk as Workbook, sh as Worksheet, rng as Range
Dim sh1 as Worksheet
set sh1 = ActiveSheet
set bk = Workbooks.Add(Template:=xlWBATWorksheet)
set sh = bk.worksheets(1)
set rng = sh.Range("A1")
Application.CutCopyMode = False
myFileName = Application.GetSaveAsFilename
If myFileName = False Then
Exit Sub
End If
bk.SaveAs Filename:=myFileName, _
FileFormat:=xlWorkbookNormal
Application.Goto sh1.Range("A1"), True

If ActiveSheet.AutoFilterMode = True Then
ActiveSheet.ShowAllData
End If

myRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
myRow2 = Sheet1.Cells(Rows.Count, 40).End(xlUp).Row
myRow3 = Sheet1.Cells(Rows.Count, 42).End(xlUp).Row
myRow4 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
myRow5 = Sheet2.Cells(Rows.Count, 40).End(xlUp).Row
myRow6 = Sheet2.Cells(Rows.Count, 42).End(xlUp).Row
Sheet1.Range("A1:AL" & myRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheet1.Range("AN1:AN" & myRow2), _
CopyToRange:=rng, _
Unique = False

set rng = sh.Cells(rows.count,1).end(xlup)(3)

Sheet2.Range("A1:AL" & myRow4).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheet2.Range("AN1:AN" & myRow5), _
CopyToRange:=rng, _
Unique:=False
bk.Save
End Sub