强制排名宏excelvba

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

编辑删除"helper"个值

已编辑 以添加 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 计数目的又用于排名更新

强制排名宏excelvba

Forced ranking macro excel vba

excel

vba

ranking