强制排名宏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 Rout 的答案，并且 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 Rout 的解决方案相比，它增强了以下方面：

• 更多（完整？）测试好像继续rng 处理

  在之前的解决方案中

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

  • 如果您将值粘贴到多个 rng 单元格中，则会引发错误

• 不使用单元格迭代，用于oldVal 计数目的和排名更新