將過濾的數據復制到特定的工作表中

Question

因此，我有以下代碼，該代碼使用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

任何幫助或指導，將不勝感激。

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