Forced ranking macro excel vba - vba

Question

I have the setup as shown in the image above.
Logic of the macro is if I enter a number 1 in cell B5 or in empty cell in Range("B2:B26") then the output would be in this format:
B2 3
B3 4
B4 2
B5 1
Now it gives me that output but there are certain drawbacks e.g.
if I provide input 8 to the same cell then it will still increment the ranks. I incorporated a match check to see if that value is there or not but it doesn't seem to work Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim KeyCells As Range
Dim i As Long, Cel As Range, sht1 As Worksheet, j As Long, found As Boolean
Set sht1 = Sheet1
Set KeyCells = sht1.Range("B2:C26")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Target.Column = 2 Then
For i = 2 To 26
If sht1.Range("B" & i) <> Empty And sht1.Range("B" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("B" & i).Value = sht1.Range("B" & i).Value + 1
Else: End If
Next i
Else: End If
If Target.Column = 3 Then
For i = 2 To 26
If sht1.Range("C" & i) <> Empty And sht1.Range("C" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("C" & i).Value = sht1.Range("C" & i).Value + 1
Else: End If
Next i
Else: End If
Else: End If
Call CreateDataLabels
Target.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Answer 1

Is this what you are trying? I have not extensively tested it
Option Explicit
Dim rng As Range
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oldVal As Long, i as Long
On Error GoTo Whoa
Application.EnableEvents = False
Set rng = Range("B2:B26")
If Not Intersect(Target, rng) Is Nothing Then
oldVal = Target.Value
If NumExists(oldVal, Target.Row) = True Then
For i = 2 To 26
If i <> Target.Row And Range("B" & i).Value >= oldVal Then _
Range("B" & i).Value = Range("B" & i) + 1
Next i
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Function NumExists(n As Long, r As Long) As Boolean
Dim i As Long
For i = 2 To 26
If Range("B" & i) = n And r <> i Then
NumExists = True
Exit Function
End If
Next i
End Function

Answer 2

edited to remove "helper" values
edited to add functionality for column C as well
Being Siddharth Rout's answer the solution, and having the OP's not asked for anything more, I'd propose the following as an alternative option to possibly be discussed if worth considering
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim oldVal As Long
Dim wrkRng As Range
Application.EnableEvents = False
On Error GoTo EndThis
If Continue(target, Range("B2:C26").Cells, oldVal, wrkRng) Then '<== here you set "B2:C26" as the "sensitive" range
With wrkRng
.Offset(, 2).Value = .Value
.FormulaR1C1 = "=IF(RC[2]<>"""",RC[2]+IF(and(RC[2]>=" & oldVal & ",ROW(RC)<>" & target.Row & "),1,0),"""")"
.Value = .Value
.Offset(, 2).ClearContents
End With
End If
EndThis:
If Err Then MsgBox Err.Description
Application.EnableEvents = True
Exit Sub
End Sub
Function Continue(target As Range, rng As Range, oldVal As Long, wrkRng As Range) As Boolean
If target.Cells.Count = 1 Then
If Not IsEmpty(target) Then ' if cell has not been cancelled
Set wrkRng = Intersect(target.EntireColumn, rng)
If Not wrkRng Is Nothing Then
oldVal = target.Value
Continue = Application.WorksheetFunction.CountIf(wrkRng, oldVal) > 1
End If
End If
End If
End Function
as compared to Siddharth Rout's solution, it enhances the following:
more (complete?) testing as if to go on with rng processing
in previous solution
if you cancelled a cell in rng it'd add 1's in all rng cells
if you pasted values in more then one rng cells it'd throw an error
no use of cells iteration, both for oldVal counting purposes and for ranking updating