新しいシートに貼り付けた後のソースからの行全体の削除

Question

ソースコード（ "ステータスレポート"）の列 "I"の行を削除する必要があるまで、このコードのすべてがうまく機能します。私は一度に1つの行だけを削除するように見えるので、私は削除するすべての行をクリアするために、このマクロを何回か実行する必要があります。

どのようにしてこの行を削除し、このコードを1回だけ実行することができますか？あなたの助けのための

Sub CopyYes() 
Dim c As Range 
Dim j As Integer 
Dim Source As Worksheet 
Dim Target As Worksheet 

' Change worksheet designations as needed 
Set Source = ActiveWorkbook.Worksheets("Status Report") 
Set Target = ActiveWorkbook.Worksheets("Sheet1") 

j = 1  ' Start copying to row 1 in target sheet 
For Each c In Source.Range("I1:I1000") ' Do 1000 rows 
    If c = 1 Then 
     Source.Rows(c.Row).Copy Target.Rows(j) 
     j = j + 1 
     Source.Rows(c.Row).EntireRow.Delete 
    End If 
Next c 

End Subの

ありがとう！

Answer 1

どのようにですか？これは、@ yassによって示唆されているように、最後の行から始まり、後方に働きます。

Sub CopyYes() 
Dim c As Range 
Dim j As Integer 
Dim Source As Worksheet 
Dim Target As Worksheet 

Dim lastRow As Long 

' Change worksheet designations as needed 
Set Source = ActiveWorkbook.Worksheets("Status Report") 
Set Target = ActiveWorkbook.Worksheets("Sheet1") 

blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row ' Start copying to row 1 in target sheet 

lastRow = 1000 
' lastRow = Source.Cells(Source.Rows.Count, 9).End(xlUp).Row ' Uncomment this line if you want to do ALL rows in column I 

With Source 
    For i = lastRow To 1 Step -1 
     If .Cells(i, 9).Value = 1 Then 
      If blankRow = 1 Then 
       .Rows(i).Copy Target.Rows(blankRow) 
      Else 
       .Rows(i).Copy Target.Rows(blankRow + 1) 
      End If 
      blankRow = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row 
      .Rows(i).EntireRow.Delete 
    Next i 
End With 

End Sub 

注：主な違いは、Forループです。 AFAIKでは、ループバックをFor each x in Rangeできません。