Copying Cells and Changing BG color in Excel 2013

Question

I am attempting to create a summary page in Excel for projects under discussion. Each separate sheet in the workbook will have a writeup of the project, status, expected ROI, etc. The first page in the workbook will have a summary of salient points from each project, one project per line.

Here is the code that I have, adapted from this answer here, since I am not copying a range but rather specific cells.

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

The behavior that I am getting is that on the first activation, the copy functions as expected, ie. sheet2:B3 gets copied to summary page:B6, sheet2:C8 gets copied to summary page:C6, sheet4:B3 to summary page:B7 , etc.

The anomalous performance:

• If I click off the summary page and back, all data gets copied only to the first line. (So sheet2 data appears in the correct row, then it gets overwritten by subsequent sheets).
• Only the background for B6 gets changed. No other cell gets changed - Solved

Edit: If I manually clear the data from the summary page and reactivate, it works as expected for the data fill. It also works if I clear the area in code. What is different about the offset when there is data already in a cell that causes it not to advance to the next row?

I've tried a few different approaches, any pointers on where I am missing something on multiple runs?

Answer 1

It's need to move setting color code.

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