强制排名宏excel vba

Question

我的安装如上图所示。

逻辑宏的是，如果我在细胞B5或在Range("B2:B26")空单元格中输入一个数字1则输出将是这种格式：

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列添加功能以及

是亚洲时报Siddharth溃败的答案的解决方案，并具有OP没有要求任何更多，我会建议以下作为备选方案，可能讨论如果值得考虑

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 

相比，亚洲时报Siddharth溃败的解决方案，它增强了以下内容：

• 以上（完成？）测试，如果在之前的解决方案与rng处理

  去

  • 如果您取消了rng中的某个单元格，则会在所有rng单元格中添加1单元格

  • ，如果你在一个以上rng细胞粘贴值它会抛出一个错误

• 没有用细胞迭代，既为oldVal计数目的和排名更新