Question

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

e.g。

3     John
2     Jane
5     James
1     Jonah
4     Jeremy

在这里，我将按顺序联系约拿，简，约翰，杰里米和詹姆斯。

我打算在列表中添加一个新人（Kate），我打算联系她的第二个。新列表看起来像这样：

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

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

我强烈怀疑我需要设置一个Worksheet Change事件......逻辑是这样的：

如果将数字输入目标范围（在本例中为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

这将处理新的排名条目，删除排名条目，将排名从高变低，从低变高。

感谢您的帮助！

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

4 个答案: