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列的功能

由于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计数和排名更新

强制排名宏excel vba

2 个答案: