强制排名macrosExcel vba

我有如上图所示的设置。

macros的逻辑是如果我在单元格B5input一个数字1 ，或者在Range("B2:B26")中的空单元格中input，则输出将采用以下格式：

 B2 3 B3 4 B4 2 B5 1 

现在它给了我输出，但有一些缺点，例如

如果我向同一个单元提供input8 ，那么它仍然会增加队伍的数量。 我纳入了匹配检查，看看是否有价值，但它似乎并没有工作任何帮助，将不胜感激。

  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

这是你正在尝试？ 我还没有广泛的testing它

 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的function

由于Siddharth Rout的回答是解决scheme，并且OP没有要求任何更多的东西，所以如果值得考虑的话，我会提出以下作为可能的讨论的备选scheme

 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 Rout的解决scheme相比，它增强了以下几点：

• 更多（完整的？）testing，好像继续进行rng处理

  在以前的解决scheme

  • 如果你在rng取消了一个单元格，它会在所有的rng单元格中加1

  • 如果你在多于一个单元格中粘贴值，它会引发错误

• 没有使用单元迭代，既为oldVal计数的目的和排名更新