在Excel 2013中複製單元格和更改BG顏色

Question

我正在嘗試在Excel中爲正在討論的項目創建一個摘要頁面。工作簿中的每個單獨的工作表都將對項目，狀態，預期的投資回報率等進行說明。工作簿中的第一頁將彙總每個項目的顯着點，每行一個項目。

這裏是我的代碼，從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中：B3被複制到摘要頁面：B6，Sheet2中：C8被複制到摘要頁面：C6，sheet4：B3到摘要頁面：B7等

反常的表現：

• 如果我點擊關閉摘要頁面並返回，所有數據僅複製到第一行。 （所以sheet2數據出現在正確的行中，然後被後續的表格覆蓋）。
• 只有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