将行复制到另一个表的下一个空行

Question

我试图根据几个条件将行复制到新工作表中。

我设法写一个宏，可以找到一行并将其复制到一张新表，但不幸的是我覆盖了以前的条目。

这对于stackoverflow有一些解决方案 - 我搜索了诸如“将行复制到空行中的新表”等 - 但我不能让他们的工作只是复制这些代码在这些答案（没有正确理解代码）。

如何将结果复制到新工作表中的下一个空行？

Sub FilterAndCopy() 

Dim lastRow As Long 
Dim criterion As String 
Dim team1 As String 
Dim team2 As String 
Dim team3 As String 

criterion = "done" 
team1 = "source" 
team2 = "refine" 
team3 = "supply" 


Sheets("Sheet3").UsedRange.Offset(0).ClearContents 

With Worksheets("Actions") 
    .range("$A:$F").AutoFilter 
    'filter for actions that are not "done" 
    .range("$A:$F").AutoFilter field:=3, Criteria1:="<>" & criterion 
    'filter for actions where "due date" is in the past 
    .range("$A:$F").AutoFilter field:=6, Criteria1:="<" & CLng(Date) 

    'FIRST TEAM 
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team1 
    'iff overdue actions exist, copy them into "Sheet3" 
    lastRow = .range("A" & .rows.Count).End(xlUp).row 
    If (lastRow > 1) Then 
     .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ 
      Destination:=Sheets("Sheet3").range("A1") 
    End If 

    'SECOND TEAM 
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team2 
    'iff overdue items exist, copy them into "Sheet3" 
    lastRow = .range("A" & .rows.Count).End(xlUp).row 
    If (lastRow > 1) Then 
     'find last row with content and copy relevant rows 
     .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ 
      Destination:=Sheets("Sheet3").range("A1") 
    End If 

    'THIRD STREAM 
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team3 
    'iff overdue items exist, copy them into "Sheet3" 
    lastRow = .range("A" & .rows.Count).End(xlUp).row 
    If (lastRow > 1) Then 
     'find last row with content and copy relevant rows 
     .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ 
      Destination:=Sheets("Sheet3").range("A1") 
    End If 

End With 
End Sub 

Answer 1

您只需在新工作表中再次使用您的LastRow代码。

所以尽量

If (lastRow > 1) Then 
    LastRow2 = worksheets("Sheet3").range("A" & rows.count).end(xlup).row + 1 
    'find last row with content and copy relevant rows 
    .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ 
     Destination:=Sheets("Sheet3").range("A" & LastRow2) 
End If 

这就会发现你的表3的最后使用的行和将其粘贴在它下面。

希望这会有所帮助。