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

Question

所以我有以下代码，它使用 excel 中的高级过滤器功能为我过滤一些条件，然后将其复制到具有条件名称的新工作簿中。我现在想做的是，嗯，让我们说过滤条件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
    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

任何帮助或指导将不胜感激。

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