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
--
Regards,
Tom Ogilvy
"Dave F" wrote:
> 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
>
>
Similar Threads
