Sheet1からコピーしてSheet2に貼り付ける範囲を完全修飾する方法は？

Question

スクリプトを実行して、Sheet1で黄色に強調表示されているセルを見つけ、黄色であればSheet2にコピー/貼り付けします。下のコードはうまくいくはずですが、この行では失敗しています。

rc.Copy rd 

基本的に、私はシート1の上に、列2、3に値を連結し、17したい、とのSheet2にすべてをコピー/ペーストします。私はワークシート参照のいくつかの種類が不足していると思っていますが、私は確かに分かりませんし、今のところ何も私のために働いていません。しかし...私はこれがかなり近いと思う！どんな助けもありがとう！

Sub ColorCopier() 
Dim i As Long 
Dim j As Long 
Dim sht As Worksheet 
Dim LastRow As Long 
Set sht = ThisWorkbook.Worksheets("Version Control") 
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1 

    'k = 1 
    Set rc = Sheets("Cobrand Tasklist").UsedRange 
    For i = 1 To rc.Rows.Count 
     For j = 1 To rc.Columns.Count 

      If Cells(i, j).Interior.ColorIndex = 6 Then 

        If j = 2 Then 
        Set rc = Cells(i, j) 
        Set rd = Sheets("Version Control").Cells(LRow, 4) 
         rc = "Task #" & rc 
         rc.Copy rd 
        End If 

        If j = 3 Then 
        Set rc = Cells(i, j) 
        Set rd = Sheets("Version Control").Cells(LRow, 4) 
         rc = "Task Title " & rc 
         rc.Copy rd 
        End If 

        If j = 17 Then 
        Set rc = Cells(i, j) 
        Set rd = Sheets("Version Control").Cells(LRow, 4) 
         rc = "Task Description " & rc 
         rc.Copy rd 
        End If 

       LRow = LRow + 1 
      End If 
     Next 
    Next 
End Sub 

Answer 1

実際に同じコードを繰り返すのを止めるためにコードを圧縮することができます。しかし、私はあなたがしようとしていると思っていることとは異なる方法を説明するために、あなたがそれをやったやり方にしました。

Dim i As Long 
Dim j As Long 
Dim sht As Worksheet 
Dim LastRow As Long 
Dim rng As Range 
Dim str As String 
Dim rng As Range 

' 
Set sht = ThisWorkbook.Worksheets("Version Control") 
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1 

    'k = 1 
    Set rc = Sheets("Cobrand Tasklist").UsedRange 
    For i = 1 To rc.Rows.Count 
     For j = 1 To rc.Columns.Count 

      If Cells(i, j).Interior.ColorIndex = 6 Then 

        If j = 2 Then 
        Cells(i, j).Value = "Task #" & Cells(i, j).Value 
        If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j) 
        End If 

        If j = 3 Then 
        Cells(i, j).Value = "Task Title " & Cells(i, j).Value 
        If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j) 
        End If 

        If j = 17 Then 
        Cells(i, j).Value = "Task Description " & Cells(i, j).Value 
        If Not rng Is Nothing Then Set rng = Union(rng, Cells(i, j)) Else Set rng = Cells(i, j) 
        End If 

       LRow = LRow + 1 
      End If 
     Next 
    Next 
    rng.Copy Sheets("Version Control").Cells(LRow, 4) 

ループ内で毎回コピーするのではなく、1行にコピーアンドペーストするとコードが大幅に高速化されます。