VBAマクロコピー＆ペースト、個別の場所に貼り付けます

Question

列Jの「今後/完了/進行中」としてマークされているかどうかによって、あるシートから別のシートに情報をコピーして貼り付けるマクロを作成しようとしていますオリジナルシート（これは「トラッカー」と呼ばれます）。 これは動作しますが、トラッカーシートから行全体をコピーしているだけで、列A：Kをコピーする必要があるという問題があります。理想的には、ステータスに応じてSheet1の別の場所に結果を掲載するのが理想的ですが、後でそれを行うために別のマクロをいつでもかけることができます。私はVBAで少し弱いので、問題の一部になる可能性があるので、私は既存のマクロを盗まれていると告白する必要があります。多くのありがとうございます。

Sub Copybasedonstatus() 
'Niall McCracken 12/12/16 

Dim lRow, cRow As Integer   
lRow = Sheets("Tracker").Range("A800").End(xlUp).Row 

For j = lRow To 1 Step -1  
    If Sheets("Tracker").Range("J" & j) = "Upcoming" Then 
     cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row 
     Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

    ElseIf Sheets("Tracker").Range("J" & j) = "Complete" Then 
     cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row 
     Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

    ElseIf Sheets("Tracker").Range("J" & j) = "In Progress" Then 
     cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row 
     Sheets("Tracker").Rows(j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

    End If 
Next 

End Sub 

Answer 1

xコピーした行（列A：K）を何番目（またはどこ）に貼り付けるかを決めたら、それに応じて修正することができます。

私はWith Sheets("Tracker")ステートメントを使用してコードを短くして（バグの軽減にも役立ちます）、IfをSelect Case .Range("J" & j).Valueに置き換えました。

注：行やセルを削除していない場合は、実際にループバックする必要はありません。必要に応じて、通常のFor j = 1 To lRowを使用することができます。

コード

Option Explicit 

Sub Copybasedonstatus() 

'Niall McCracken 12/12/16 

Dim lRow As Long, cRow As Long, j As Long 

With Sheets("Tracker") 
    lRow = .Range("A800").End(xlUp).Row 

    ' another method of finding last row in Column A (skipping blank cells in the middle) 
    lRow = .Cells(.Rows.Count, "A").End(xlUp).Row 

    For j = lRow To 1 Step -1 
     cRow = Sheets("Sheet1").Range("A800").End(xlUp).Row 

     Select Case .Range("J" & j).Value 
      Case "Upcoming" 
       .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

      Case "Complete" 
       .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

      Case "In Progress" 
       .Range("A" & j & ":K" & j).Copy Destination:=Sheets("Sheet1").Range("A" & cRow + 1) 

     End Select 
    Next 
End With 

End Sub