Принудительный макро рейтинг Excel VBA

Question

У меня есть настройки, как показано на рисунке выше.

Логика макроса если ввести номер 1 в ячейке B5 или в пустой ячейке в Range("B2:B26"), то выход будет в следующем формате:

B2 3 
B3 4 
B4 2 
B5 1 

Теперь он дает мне этот вывод, но есть определенные недостатки, например

Если я предоставил ввод 8 в ту же ячейку, то он все равно увеличит ряды. Я включил проверку соответствия, чтобы увидеть, есть ли это значение или нет, но, похоже, не работает. Любая помощь будет оценена.

 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

Это то, что вы пытаетесь? Я не широко тестировал

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

отредактирован удалить «помощник» значение

отредактировано добавить функциональность для столбца C, а

ответа

Будучи Сиддхарт разгромить в растворе, и с ОП не просили ничего больше, я бы предложил следующее в качестве альтернативного варианта, который можно было бы обсудить, если стоит рассмотреть

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 

по сравнению с раствором Сиддхарт разгромом, он усиливает следующее:

• более (в комплекте?) Тестирование, как если идти с rng обработки

  в предыдущем решении

  • , если вы отменили номер в rng, добавили бы 1's всего rng

  • если вы вставили значение в более чем один rng клеток было бы бросить ошибку

• нет использования клеток итерационных, как для oldVal целей подсчета и не рейтинг обновления