在 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