別のシートの次の空の行に行をコピー

Question

いくつかの基準に基づいて新しいシートに行をコピーしようとしています。

行を見つけて新しいシートにコピーできるマクロを書きましたが、残念ながら前のエントリを上書きしています。

これにはいくつかの解決策があります。「空行の新しいシートに行をコピーする」などを検索しましたが、これらのコードをコピーするだけでは機能しませんでした答え（コードを正しく理解していない）。

結果を新しいシートの次の空の行にコピーするにはどうすればよいですか？

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の最後に使用された行を検索し、その下に貼り付けます。

これが役に立ちます。