Need help on generating non-duplicated result

[Bon]

Hello All

Please give me some advices on generating non-duplicated result. My
idea and codes are as follow.

I got two worksheets - Subjects worksheet and Result worksheet. The
subject worksheet contains subjects name, years and page numbers. It
looks like

1990 1991 1992 1993 1994 Total Page
Eng 1 7 4 6 8 5
Maths 2 3 4 5 6
Chem 3 9 7 6 4
Phy 3 5 8 9 10 10

When the user click the page number, cell will be highlight and total
page of that subject will be calculated and displayed in total page
column. For example, teacher A clicks Cells(2,2), Cells(2,4) and
Cells(5,5), those will be highlighed and the total page number for Eng
and Phy will be calculated and shown on total page column respectively
(i.e. 5 and 10).

On the Result worksheet, it will show highlighed subject, year and page
number only. For the above example, it will show:
1990 1992 1994
Eng 1 4
Phy 10

But, my result is look like:
1990 1992 1994
Eng 1
Eng 4
Phy 10

Here is my code for Result worksheet:

Private Sub Worksheet_Activate()
Dim ALWorksheet As Worksheet
Dim intPasteYear As Integer
Dim intPasteSubj As Integer
Dim intPageNum As Integer

Dim bYearFlag As Boolean
Dim bSubjFlag As Boolean

Set ALWorksheet = Worksheets("Subjects")

intPasteYear = 2
intPasteSubj = 2

intPageNum = 2

For intCol = 2 To 12
bYearFlag = False

For intRow = 2 To 12

If ALWorksheet.Cells(intRow, intCol).Interior.ColorIndex =
6 Then
If bYearFlag = False Then
With Cells(1, intPasteYear)
.Value = ALWorksheet.Cells(1, intCol)
.Font.Bold = True
intPasteYear = intPasteYear + 1
bYearFlag = True
End With
End If

Cells(intPasteSubj, 1) = ALWorksheet.Cells(intRow, 1)
intPasteSubj = intPasteSubj + 1

Cells(intPageNum, intPasteYear - 1) =
ALWorksheet.Cells(intRow, intCol)
intPageNum = intPageNum + 1
End If
Next
Next
End Sub

Please give me some suggestion on solving this problem.

Thank you very much

Bon