Forced ranking macro excel 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