Probleme de repition de resultat

Bonjour a tous ,

j'ai un code qui me fait une comparaison et qui me rend des resultats seulement s'il y a un changement , le probleme c'est que ce code me rend le resultat meme s'il n'y a pas de changement comme ce qu'il y a dans la photo :
http://imgh.us/excel.png
voila le code sur le quel je travaille si quelqu'un peut m'aider s'il vous plait et merci d'avance

Sub ComparisonRanking()
Dim rnk, MaxRnk As Integer
Dim LastKRow, LastPRow, rw, rwK, rwO As Long

Application.ScreenUpdating = False
LastKRow = Cells(Rows.Count, "K").End(xlUp).Row
Range("N3:P" & LastKRow).ClearContents
MaxRnk = Application.WorksheetFunction.Max(Range(Cells(3, "K"), Cells(LastKRow, "K")))


For rnk = 1 To MaxRnk
    LastPRow = Cells(Rows.Count, "P").End(xlUp).Row
 rw = LastPRow + 1
    For rwK = 3 To LastKRow

        If Cells(rwK, "K") = rnk Then
            Cells(rw, "N") = Cells(rwK, "G")   'Release 2 CoreSiteCode
            Cells(rw, "O") = Cells(rwK, "H")  'Release 2 SiteCode
            Site = Cells(rw, "O")
            Call CheckIfNew
                If Cells(rw, "P") = "New com" Then
                    Call FindNEWFeatures
'***************Inserts 'New Rank' if Site is only in Release 2
                    rwO = Columns(7).Find(Cells(rw, "O")).Row
                    Cells(rw, "Q") = Cells(rw, "Q") & "New Rank: " & Cells(rwO, "K")
'***************
                    GoTo NEWCOM
                End If
            
            GoTo PassThis
         End If
    Next rwK
    
PassThis:

LastARow = Cells(Rows.Count, "A").End(xlUp).Row
    For rwA = 3 To LastARow
        If Cells(rwA, "A") = Cells(rw, "N") Then
            Cells(rw, "P") = "Ranking"
'********************************Insert 'PNR % Change'to 2 decimal places
            pc = Application.Round((Cells(rwK, "J") / Cells(rwA, "D") - 1) * 100, 2)
            Cells(rw, "Q") = "Old Rank: " & Cells(rwA, "E") & ", " & "New Rank: " & Cells(rwK, "K") & ", " & "PNR % Change: " & pc

            'Cells(rw, "Q") = "Old Rank: " & Cells(rwA, "E") & ", " & "New Rank: " & Cells(rwK, "K") & ", " & _
       "Old Total_pnr's: " & Cells(rwA, "D") & ", " & "New Total_pnr's: " & Cells(rwK, "J")
'********************************
            Cells(rw + 1, "P") = "Features"
            Call FindOLDFeatures
            Call FindNEWFeatures
        End If
    Next rwA
NEWCOM:
Next rnk
Call CheckIfOld
Application.ScreenUpdating = True
End Sub