在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