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

因此，我有下面的代码，它使用excel中的advancedfilter函数为我筛选一些条件，然后将这些条件复制到新工作簿中，并使用这些条件的名称。我现在想让它做的是，嗯，让我们假设过滤标准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

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

希望下面的代码符合您的期望

Dim单元格作为范围
像细绳一样暗淡
curpath=ActiveWorkbook.Path&“\”
Application.ScreenUpdating=False
Application.DisplayAlerts=False
对于范围内的每个单元格（“fbtlist”）
[valsalesman]=单元格值
范围（“myFBT”）。高级筛选器操作：=xlFilterCopy_
criteriarange:=范围（“标准”），copytorange:=（“提取”），unique:=假
范围（范围（“提取”）、范围（“提取”）.End（xlDown））.Copy
工作簿。添加“而不是创建”使用工作簿。打开并执行以下操作
'您可以插入此代码以查找最后使用的行
a=2
“当单元格（a，2）”时执行此操作
a=a+1
环
单元格（a，1）。选择
Activesheet.paste
ActiveWorkbook.SaveAs文件名：=curpath&cell.Value&Format（现在是“ddmmyyyy-hhmmss”）和“.xlsx”，文件格式：=xlOpenXMLWorkbook，CreateBackup:=False
活动窗口，关闭
范围（范围（“提取”）、范围（“提取”）.End（xlDown））.ClearContents
下一个细胞
端接头

嘿，谢谢你，尤瓦拉。但是假设条件的名称是“Criteria1”，我的目录中有一个类似名称的工作簿，是否有vba代码可以自动将条件名称匹配到工作簿并粘贴到那里，而我不需要逐个执行。大约有10本工作簿，标准经常更改，因此vba更容易执行。您可以检查此线程

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