将过滤的数据复制到特定的工作表中

Question

So i have the following code which uses the advancedfilter function in the excel to filter for me few criteria and then copy this into new workbook wit the name of the criteria. What I would like it to do now is to, hmm, lets say filter criteria1, copy it, and instead of creating new workbook and paste it there, I want it to paste it into the current workbook with the same name, but the trick here is that I do not want it to overwrite the current data that i have but to find the last row (i know how to do it) and paste it there.

Dim cell As Range
Dim curPat As String

curpath = ActiveWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each cell In Range("fbtlist")
    [valsalesman] = cell.Value
    Range("myFBT").AdvancedFilter Action:=xlFilterCopy, _
        criteriarange:=Range("criteria"), copytorange:=("extract"), unique:=False
    Range(Range("extract"), Range("extract").End(xlDown)).Copy
    Workbooks.Add
    ActiveSheet.Paste
    ActiveWorkbook.SaveAs Filename:=curpath & cell.Value & Format(Now, "ddmmyyyy - hhmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Range(Range("extract"), Range("extract").End(xlDown)).ClearContents
Next cell

End Sub

any help or guidance would be appreciated.

Answer 1

Dim cell As Range
Dim curPat As String

curpath = ActiveWorkbook.Path & "\"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each cell In Range("fbtlist")
     [valsalesman] = cell.Value
     Range("myFBT").AdvancedFilter Action:=xlFilterCopy, _
    criteriarange:=Range("criteria"), copytorange:=("extract"), unique:=False
Range(Range("extract"), Range("extract").End(xlDown)).Copy
Workbooks.Add  'Instead of creating use the Workbook.open and perform as below
'You may insert this code to find the last used row
a = 2
do while cells(a, 2) <>""
a = a+1
loop
cells(a,1).select
Activesheet.paste
ActiveWorkbook.SaveAs Filename:=curpath & cell.Value & Format(Now, "ddmmyyyy - hhmmss") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Range(Range("extract"), Range("extract").End(xlDown)).ClearContents
Next cell

End Sub