将数字添加到唯一但无序的数字列表中 - 工作表更改

Question

我有一个 excel 文件，其中包含 A 列中的数字列表和 B 列中的名称列表。数字是唯一的（没有数字重复），但数字不按顺序排列。它代表了我每天需要与他们联系的顺序。

例如

3     John
2     Jane
5     James
1     Jonah
4     Jeremy

在这里，我将按顺序联系 Jonah、Jane、John、Jeremy 和 James。

我计划在列表中添加一个新人 (Kate)，并计划第二次联系她。新列表如下所示：

4     John
3     Jane
6     James
1     Jonah
5     Jeremy
2     Kate

现在，我将按顺序联系 Jonah、KATE、Jane、John、Jeremy 和 James。这里的重要事实是，新条目下方的所有数字保持不变，但等于或高于新条目的所有数字都增加 1。有时我会在列表底部添加新条目，有时我会添加新条目通过在列表中间插入一个新行。有时我需要将人员从列表中删除，并且我想反转事件（对于等于或大于新删除的数字的所有数字，他们将从其原始值中减去 1）。

我强烈怀疑我需要设置一个工作表更改事件......逻辑是这样的：

如果在目标范围内输入了一个数字（在本例中为 A 列），则 A列中所有大于或等于新输入数字的数字将是原始值+1。

如果从目标范围中删除了一个数字，那么 目标范围内大于或等于新输入数字的所有数字都将是原始值 - 1。

在 VBA 中表达这一点的最佳方式是什么？

非常感谢！

Answer 1

下面是一些应该适合你的注释代码：

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngCheckA As Range, ATarget As Range, ACell As Range
    Dim varBefore As Variant
    Dim varAfter As Variant
    Dim lChangeType As Long
    Dim rngActive As Range

    Set rngCheckA = Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))
    Set rngActive = ActiveCell

    Application.EnableEvents = False
    On Error GoTo CleanExit

    Set ATarget = Intersect(rngCheckA, Target)
    If Not ATarget Is Nothing Then
        'Code only runs if a single cell in column A was changed
        If ATarget.Cells.Count = 1 Then
            'Get previous value
            Application.Undo
            varBefore = ATarget.Value

            'Get new value
            Application.Undo
            varAfter = ATarget.Value

            'Check how list changed
            If Len(varBefore) = 0 And IsNumeric(varAfter) Then
                'New value was added to the list
                lChangeType = 1
            ElseIf Len(varAfter) = 0 And IsNumeric(varBefore) Then
                'Existing value was removed (deleted) from list
                lChangeType = 2
            ElseIf IsNumeric(varBefore) And IsNumeric(varAfter) Then
                'Existing value in list was changed
                lChangeType = 3
            End If

            'Update list values appropriately based on how the list was changed
            For Each ACell In rngCheckA.Cells
                If Len(ACell.Value) > 0 And IsNumeric(ACell.Value) And ACell.Address <> ATarget.Address Then
                    'Only need to update values in list that are greater than or equal to the changed value
                    If ACell.Value >= ATarget.Value Then
                        Select Case lChangeType
                            Case 1: ACell.Value = ACell.Value + 1                               'New value added, increase values
                            Case 2: ACell.Value = ACell.Value - 1                               'Existing value removed, decrease values
                            Case 3: If ACell.Value = ATarget.Value Then ACell.Value = varBefore 'Existing value changed, swap numbers
                        End Select
                    End If
                End If
            Next ACell
        End If
    End If

'In the event of any errors, turn EnableEvents back on
'The Application.Undo will change the selected cell, so set it back to what it was
CleanExit:
    Application.EnableEvents = True
    rngActive.Select

End Sub

Answer 2

与@tigeravatar 的解决方案相比，这里有一个非常基本的例程，它假设您总是在范围的最后一行输入一个数字，并且很少进行验证。假设在 A 列中输入了数字。

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Column <> 1 Then Exit Sub
    If Target.Row <> Cells(Rows.Count, 1).End(xlUp).Row Then Exit Sub

    Application.EnableEvents = False

    ' Check each cell above and update if necessary...
    Dim r As Range
    For Each r In Range("A1:A" & Target.Row - 1)
        If r >= Target Then r = r + 1
    Next

    Application.EnableEvents = True

End Sub

Answer 3

好的，试一试，我可以在添加文本时让宏工作。将此插入工作表区域（右键单击工作表选项卡，单击“查看代码”）：

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Integer, newCallOrder As Integer, newEntryRow As Integer, newEntryVal As Integer
Dim orderCol As Integer, nameCol As Integer

orderCol = 1
nameCol = 2

Dim cel As Range, rng As Range

If Target.Columns.Count > 3 Then Exit Sub
If Target.Column = 1 And Target.Offset(0, 1).Value = "" Then Exit Sub
If Target.Column = 2 Then
 If Target.Offset(0, -1).Value = "" Then
    Exit Sub
 End If
End If

Application.EnableEvents = False

newEntryRow = Target.Row
newEntryVal = Cells(newEntryRow, orderCol).Value

Debug.Print "You added '" & newEntryVal & "' to row " & newEntryRow & "."

lastRow = ActiveSheet.UsedRange.Rows.Count
Set rng = Range(Cells(1, 1), Cells(lastRow, 1)) ' use lastRow - 1, to get existing range.
newCallOrder = Cells(lastRow, 1).Value

Dim checkNew As Integer
checkNew = WorksheetFunction.CountIf(rng, newEntryVal)

If checkNew > 0 Then

    For Each cel In rng
        If cel.Row <> newEntryRow Then
            cel.Select
            If cel.Value >= newEntryVal Then
                cel.Value = cel.Value + 1 '(cel.Value - newEntryVal)
            ElseIf newEntryVal < cel.Value Then
                cel.Value = cel.Value - 1
            End If
        End If
    Next cel
Else
    MsgBox ("No new order necessary")
End If

Application.EnableEvents = True

End Sub

（当我添加这个时，发布了两个答案）。我会继续把它留在这里，以防有一部分你可以融入其他答案。

Answer 4

感谢您对我最初的问题的帮助，并对延迟表示歉意。

我使用了tigeravatar 的大部分代码，并对其进行了一些修改，并添加了一些内容。请在下面找到...似乎有效。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngCheckA As Range, ATarget As Range, ACell As Range
Dim varBefore As Variant
Dim varAfter As Variant
Dim lChangeType As Long
Dim rngActive As Range

Set rngCheckA = Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))
Set rngActive = ActiveCell

Application.EnableEvents = False
On Error GoTo CleanExit

Set ATarget = Intersect(rngCheckA, Target)
If Not ATarget Is Nothing Then
    'Code only runs if a single cell in column A was changed
    If ATarget.Cells.Count = 1 Then
        'Get previous value
        Application.Undo
        varBefore = ATarget.Value

        'Get new value
        Application.Undo
        varAfter = ATarget.Value

        'Update list values appropriately based on how the list was changed
        For Each ACell In rngCheckA.Cells
            If IsNumeric(varAfter) And IsEmpty(varBefore) And ACell.Address <> ATarget.Address Then
                'add rank
                If Len(varBefore) = 0 And IsNumeric(varAfter) Then
                If ACell.Value >= ATarget.Value Then
                    ACell.Value = ACell.Value + 1
                End If
            ElseIf IsEmpty(varAfter) And IsNumeric(varBefore) And ACell.Address <> ATarget.Address Then
                'delete rank
                If Len(varAfter) = 0 And IsNumeric(varBefore) Then
                If ACell.Value > varBefore Then
                    ACell.Value = ACell.Value - 1
                End If
                End If
            ElseIf IsNumeric(varBefore) And IsNumeric(varAfter) And ACell.Address <> ATarget.Address Then
                'lower rank
                If varBefore > varAfter Then
                    If ACell.Value >= varAfter And ACell.Value < varBefore Then
                        ACell.Value = ACell.Value + 1
                    End If
                'raise rank
                ElseIf varBefore < varAfter Then
                    If ACell.Value <= varAfter And ACell.Value > varBefore Then
                        ACell.Value = ACell.Value - 1
                    End If
                End If
            End If
        Next ACell
    End If
End If

'In the event of any errors, turn EnableEvents back on
'The Application.Undo will change the selected cell, so set it back to what it was
CleanExit:
    Application.EnableEvents = True
    rngActive.Select

End Sub

这会处理新的排名条目、删除排名条目、将排名从高到低以及从低到高。

感谢您的帮助！