ExcelでセルをコピーしてBG色を変更する

Question

議論中のプロジェクトのExcelで要約ページを作成しようとしています。ワークブックの各個別のシートには、プロジェクト、ステータス、予想されるROIなどが記載されています。ワークブックの最初のページには、各プロジェクトの顕著な点の概要が1行に1つずつ表示されます。

範囲はコピーせず、むしろ特定のセルをコピーしているので、これはthis answer hereに適合したコードです。

Private Sub Worksheet_Activate() 
Dim ws As Worksheet, sh As Worksheet, pRng As Range 
Dim rNum As Integer 
Dim nModCheck As Integer 

Set ws = Sheets("Project Summary Page") 
rNum = 6 
For Each sh In Sheets 
    If sh.Name <> ws.Name Then 
     If sh.Name <> "Sheet3" Then 
      sh.Range("B3").Copy 

      Set pRng = ws.Cells(rNum, 2).End(xlUp).Offset(1, 0) 
      pRng.PasteSpecial Paste:=xlPasteFormats 
      pRng.PasteSpecial Paste:=xlPasteValues 

      nModCheck = rNum Mod 2 
      If nModCheck = 0 Then 
       Selection.Interior.ColorIndex = 15 
      End If 

      sh.Range("C8").Copy 
      Set pRng = ws.Cells(rNum, 3).End(xlUp).Offset(1, 0) 
      pRng.Select 
      If nModCheck = 0 Then 
       Selection.Interior.ColorIndex = 15 
      End If 
      pRng.PasteSpecial Paste:=xlPasteFormats 
      pRng.PasteSpecial Paste:=xlPasteValues 

      rNum = rNum + 1 
     End If 
    End If 
    Application.CutCopyMode = 0 
    ws.Cells(rNum, 1).Value = rNum 
Next sh 
'Columns("B:K").EntireColumn.AutoFit 
End Sub 

私が得意とする動作は、最初の起動時にコピーが期待通りに機能することです。 Sheet2：私がクリックした場合

• ：B6、Sheet2の：：C8は、概要ページにコピーされます：C6、シート4：要約ページへのB3：B7など

  異常なパフォーマンスB3は、概要ページにコピーされます要約ページをオフにして戻ると、すべてのデータが最初の行にのみコピーされます。 （したがって、シート2のデータは正しい行に表示され、後続のシートで上書きされます）。

• B6の背景のみが変更されます。他のセルは変更されません。 - 解決済み

編集：手動でサマリーページからデータを消去して再度有効にすると、データの埋め込みに期待通りに機能します。また、コード内の領域をクリアすると動作します。次の行に進まないようなセル内のデータがすでに存在する場合のオフセットの違いは何ですか？

私はいくつかのアプローチを試みましたが、複数の実行で何かが不足している箇所を指摘しましたか？

Answer 1

設定カラーコードを移動する必要があります。

Private Sub Worksheet_Activate() 
Dim ws As Worksheet, sh As Worksheet, pRng As Range 
Dim rNum As Integer 
Dim nModCheck As Integer 

Set ws = Sheets("Project Summary Page") 
rNum = 6 
For Each sh In Sheets 
    If sh.Name <> ws.Name Then 
     If sh.Name <> "Sheet3" Then 
      sh.Range("B3").Copy 

      Set pRng = ws.Cells(rNum, 2).End(xlUp).Offset(1, 0) 
      pRng.PasteSpecial Paste:=xlPasteFormats 
      pRng.PasteSpecial Paste:=xlPasteValues 

      nModCheck = rNum Mod 2 
      If nModCheck = 0 Then 
       'Selection.Interior.ColorIndex = 15 
       pRng.Interior.ColorIndex = 15 
      End If 

      sh.Range("C8").Copy 
      Set pRng = ws.Cells(rNum, 3).End(xlUp).Offset(1, 0) 
      'pRng.Select 

      pRng.PasteSpecial Paste:=xlPasteFormats 
      pRng.PasteSpecial Paste:=xlPasteValues 

      If nModCheck = 0 Then '<~~ moved 
       'Selection.Interior.ColorIndex = 15 
       pRng.Interior.ColorIndex = 15 
      End If 

      rNum = rNum + 1 
     End If 
    End If 
    Application.CutCopyMode = 0 
    ws.Cells(rNum, 1).Value = rNum 
Next sh 

End Sub